diff --git a/MANIFEST b/MANIFEST index 6068e04..1972416 100644 --- a/MANIFEST +++ b/MANIFEST @@ -995,7 +995,6 @@ lib/Parrot/IO/Path.pm [devel]lib lib/Parrot/Install.pm [devel]lib lib/Parrot/Manifest.pm [devel]lib lib/Parrot/Pmc2c/Attribute.pm [devel]lib -lib/Parrot/Pmc2c/ComposedMethod.pm [devel]lib lib/Parrot/Pmc2c/Dumper.pm [devel]lib lib/Parrot/Pmc2c/Emitter.pm [devel]lib lib/Parrot/Pmc2c/Library.pm [devel]lib @@ -1007,11 +1006,9 @@ lib/Parrot/Pmc2c/PCCMETHOD.pm [devel]lib lib/Parrot/Pmc2c/PMC.pm [devel]lib lib/Parrot/Pmc2c/PMC/Null.pm [devel]lib lib/Parrot/Pmc2c/PMC/Object.pm [devel]lib -lib/Parrot/Pmc2c/PMC/ParrotClass.pm [devel]lib lib/Parrot/Pmc2c/PMC/PrintTree.pm [devel]lib lib/Parrot/Pmc2c/PMC/RO.pm [devel]lib lib/Parrot/Pmc2c/PMC/default.pm [devel]lib -lib/Parrot/Pmc2c/PMCEmitter.pm [devel]lib lib/Parrot/Pmc2c/Parser.pm [devel]lib lib/Parrot/Pmc2c/Pmc2cMain.pm [devel]lib lib/Parrot/Pmc2c/UtilFunctions.pm [devel]lib diff --git a/config/auto/pmc.pm b/config/auto/pmc.pm index 2fd7688..d0ee0ea 100644 --- a/config/auto/pmc.pm +++ b/config/auto/pmc.pm @@ -62,7 +62,6 @@ PMC2C_FILES = \\ lib/Parrot/Pmc2c/Method.pm \\ lib/Parrot/Pmc2c/PCCMETHOD.pm \\ lib/Parrot/Pmc2c/MULTI.pm \\ - lib/Parrot/Pmc2c/PMCEmitter.pm \\ lib/Parrot/Pmc2c/MethodEmitter.pm \\ lib/Parrot/Pmc2c/Library.pm \\ lib/Parrot/Pmc2c/UtilFunctions.pm \\ diff --git a/lib/Parrot/Pmc2c/Dumper.pm b/lib/Parrot/Pmc2c/Dumper.pm index 30da966..80c91f4 100644 --- a/lib/Parrot/Pmc2c/Dumper.pm +++ b/lib/Parrot/Pmc2c/Dumper.pm @@ -1,4 +1,4 @@ -# Copyright (C) 2004-2009, Parrot Foundation. +# Copyright (C) 2004-2011, Parrot Foundation. package Parrot::Pmc2c::Dumper; use strict; @@ -144,7 +144,6 @@ sub gen_parent_lookup_info { =head2 Subroutines - =head3 C $class = gen_parent_reverse_lookup_info($name, $all, $vt); diff --git a/lib/Parrot/Pmc2c/Library.pm b/lib/Parrot/Pmc2c/Library.pm index fd1f71c..a2fab44 100644 --- a/lib/Parrot/Pmc2c/Library.pm +++ b/lib/Parrot/Pmc2c/Library.pm @@ -24,7 +24,7 @@ package Parrot::Pmc2c::Library; use strict; use warnings; use File::Basename qw(basename); -use Parrot::Pmc2c::PMCEmitter (); +use Parrot::Pmc2c::PMC (); use Parrot::Pmc2c::UtilFunctions qw(dont_edit dynext_load_code c_code_coda spew); =item C diff --git a/lib/Parrot/Pmc2c/Method.pm b/lib/Parrot/Pmc2c/Method.pm index d884909..6b05872 100644 --- a/lib/Parrot/Pmc2c/Method.pm +++ b/lib/Parrot/Pmc2c/Method.pm @@ -203,7 +203,6 @@ sub pcc_signature { =head1 SEE ALSO lib/Parrot/Pmc2c/PMC/RO.pm - lib/Parrot/Pmc2c/PMCEmitter.pm lib/Parrot/Pmc2c/VTable.pm lib/Parrot/Pmc2c/PMC.pm lib/Parrot/Pmc2c/Parser.pm diff --git a/lib/Parrot/Pmc2c/PCCMETHOD.pm b/lib/Parrot/Pmc2c/PCCMETHOD.pm index 0af7665..105dac7 100644 --- a/lib/Parrot/Pmc2c/PCCMETHOD.pm +++ b/lib/Parrot/Pmc2c/PCCMETHOD.pm @@ -5,6 +5,7 @@ use strict; use warnings; use Carp qw(longmess croak); use Parrot::Pmc2c::PCCMETHOD_BITS; +use Parrot::Pmc2c::UtilFunctions qw( trim ); =head1 NAME @@ -96,28 +97,6 @@ our $reg_type_info = { at => PARROT_ARG_PMC, }, }; -# Perl trim function to remove whitespace from the start and end of the string -sub trim { - my $string = shift; - $string =~ s/^\s+//; - $string =~ s/\s+$//; - return $string; -} - -# Left trim function to remove leading whitespace -sub ltrim { - my $string = shift; - $string =~ s/^\s+//; - return $string; -} - -# Right trim function to remove trailing whitespace -sub rtrim { - my $string = shift; - $string =~ s/\s+$//; - return $string; -} - =head3 C builds and returs an adverb hash from an adverb string such as diff --git a/lib/Parrot/Pmc2c/PMC.pm b/lib/Parrot/Pmc2c/PMC.pm index 2ff4bd2..b65a321 100644 --- a/lib/Parrot/Pmc2c/PMC.pm +++ b/lib/Parrot/Pmc2c/PMC.pm @@ -26,7 +26,19 @@ use base qw( Exporter ); our @EXPORT_OK = qw(); use Storable (); use Parrot::PMC; -use Parrot::Pmc2c::Method; +use Parrot::Pmc2c::Emitter (); +use Parrot::Pmc2c::Method (); +use Parrot::Pmc2c::MethodEmitter (); +use Parrot::Pmc2c::UtilFunctions qw( + dont_edit + dynext_load_code + c_code_coda + gen_multi_name +); +use Text::Balanced 'extract_bracketed'; +use Parrot::Pmc2c::PCCMETHOD (); +use Parrot::Pmc2c::MULTI (); +use Parrot::Pmc2c::PMC::RO (); sub create { my ( $this, $pmc_classname ) = @_; @@ -443,6 +455,1122 @@ sub dump_is_current { return ( stat $dumpfile )[9] >= ( stat $pmcfile )[9]; } +sub vtable { + my ( $self, $value ) = @_; + $self->{vtable} = $value if $value; + return $self->{vtable}; +} + + +sub prep_for_emit { + my ( $this, $pmc, $vtable_dump ) = @_; + + $pmc->vtable($vtable_dump); + $pmc->init(); + + return $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->is_dynamic) ); + + $self->generate_h_file; + $emitter->write_to_file; +} + +=over 4 + +=item C + +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 ) ); + if ($self->is_dynamic) { + $c->emit("#define PARROT_IN_EXTENSION\n"); + $c->emit("#define CONST_STRING(i, s) Parrot_str_new_constant((i), s)\n"); + $c->emit("#define CONST_STRING_GEN(i, s) Parrot_str_new_constant((i), s)\n"); + } + + $self->gen_includes; + + # The PCC code needs Continuation-related macros from these headers. + $c->emit("#include \"pmc_continuation.h\"\n"); + $c->emit("#include \"pmc_callcontext.h\"\n"); + + $c->emit( $self->preamble ); + + $c->emit( $self->hdecls ); + $c->emit( $self->{ro}->hdecls ) if ( $self->{ro} ); + $self->gen_methods; + + my $ro = $self->ro; + if ($ro) { + $ro->{emitter} = $self->{emitter}; + $ro->gen_methods; + } + + $c->emit("#include \"pmc_default.h\"\n"); + + $c->emit( $self->update_vtable_func ); + $c->emit( $self->get_vtable_func ); + $c->emit( $self->get_mro_func ); + $c->emit( $self->get_isa_func ); + $c->emit( $self->pmc_class_init_func ); + $c->emit( $self->init_func ); + $c->emit( $self->postamble ); + + return 1; +} + +=item C + +Generates the C header file code for the PMC. + +=cut + +sub generate_h_file { + my ($self) = @_; + my $h = $self->{emitter}; + my $uc_name = uc $self->name; + my $name = $self->name; + + $h->emit( dont_edit( $self->filename ) ); + $h->emit(<<"EOH"); + +#ifndef PARROT_PMC_${uc_name}_H_GUARD +#define PARROT_PMC_${uc_name}_H_GUARD + +EOH + + $h->emit("#define PARROT_IN_EXTENSION\n") if ( $self->is_dynamic ); + + # Emit available functions for work with vtables. + my $export = 'PARROT_EXPORT '; + if ($self->is_dynamic) { + $export = 'PARROT_DYNEXT_EXPORT '; + $h->emit("${export}VTABLE* Parrot_${name}_get_vtable_pointer(PARROT_INTERP);\n"); + $h->emit("${export}void Parrot_${name}_class_init(PARROT_INTERP, int, int);\n"); + } + + if ($name ne 'default') { + $h->emit("${export}VTABLE* Parrot_${name}_update_vtable(ARGMOD(VTABLE*));\n"); + $h->emit("${export}VTABLE* Parrot_${name}_ro_update_vtable(ARGMOD(VTABLE*));\n"); + } + $h->emit("${export}VTABLE* Parrot_${name}_get_vtable(PARROT_INTERP);\n"); + $h->emit("${export}VTABLE* Parrot_${name}_ro_get_vtable(PARROT_INTERP);\n"); + $h->emit("${export}PMC* Parrot_${name}_get_mro(PARROT_INTERP, ARGIN_NULLOK(PMC* mro));\n"); + $h->emit("${export}Hash* Parrot_${name}_get_isa(PARROT_INTERP, ARGIN_NULLOK(Hash* isa));\n"); + + + $self->gen_attributes; + $h->emit(<<"EOH"); + +#endif /* PARROT_PMC_${uc_name}_H_GUARD */ + +EOH + $h->emit( c_code_coda() ); + return 1; +} + +=item C + +Returns the C code function declarations for all the methods for inclusion +in the PMC's C header file. + +=cut + +sub hdecls { + my ($self) = @_; + + my $hout; + my $name = $self->name; + my $lc_name = $self->name; + + # generate decls for all vtables 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); + } + + my $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : ''; + + # class init decl + $hout .= "${export}void Parrot_${name}_class_init(PARROT_INTERP, int, int);\n"; + + $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_EXPORT '; + + $hout .= "${export}VTABLE* Parrot_${lc_name}_update_vtable(ARGMOD(VTABLE*));\n" + unless $name eq 'default'; + + $hout .= "${export}VTABLE* Parrot_${lc_name}_get_vtable(PARROT_INTERP);\n"; + + $hout .= "${export}VTABLE* Parrot_${lc_name}_get_vtable_pointer(PARROT_INTERP);\n" + if ($self->is_dynamic); + + $self->{hdecls} .= $hout; + + return $self->{hdecls}; +} + +=back + +=head2 Instance Methods + +=over + +=item C + +Initializes the instance. + +=cut + +sub init { + my ($self) = @_; + + #!( 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; +} + +=item C + +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 + +Generate switch-bases VTABLE for MULTI + +=cut + +sub pre_method_gen { + my ($self) = @_; + + $self->gen_switch_vtable; + + 1; +} + +=item C + +Returns the C code for the pmc methods. + +=cut + +sub gen_methods { + my ($self) = @_; + + # vtables + 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); + } + } + + # methods + foreach my $method ( @{ $self->methods } ) { + next if $method->is_vtable; + $method->generate_body($self); + } +} + +=item C + +Returns the C code for the attribute struct definition. + +=cut + +sub gen_attributes { + my ($self) = @_; + my $attributes = $self->attributes; + + if ( @{$attributes} ) { + + Parrot::Pmc2c::Attribute::generate_start( $attributes->[0], $self ); + + foreach my $attribute ( @{$attributes} ) { + $attribute->generate_declaration($self); + } + + Parrot::Pmc2c::Attribute::generate_end( $attributes->[0], $self ); + + foreach my $attribute ( @{$attributes} ) { + $attribute->generate_accessor($self); + } + } +} + +=item C + +Returns an arrayref of MULTI function names declared in the PMC. Used to +initialize the multiple dispatch function list. + +=cut + +sub find_multi_functions { + my ($self) = @_; + + my $pmcname = $self->name; + my ( @multi_names ); + + foreach my $method ( @{ $self->methods } ) { + next unless $method->is_multi; + my $short_sig = $method->{MULTI_short_sig}; + my $full_sig = $pmcname . "," . $method->{MULTI_full_sig}; + my $functionname = 'Parrot_' . $pmcname . '_' . $method->name; + push @multi_names, [ $method->symbol, $short_sig, $full_sig, + $pmcname, $functionname, $method ]; + } + return ( \@multi_names ); +} + +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 + +Returns C code to produce a PMC's flags. + +=cut + +sub vtable_flags { + my ($self) = @_; + + my $vtbl_flag = 0; + $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'); + + return $vtbl_flag; +} + +=item C + +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 = $self->vtable_flags; + + 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 = < + +Returns the C code for the PMC's class_init function as a static +function to be called from the exported class_init. + +=cut + +sub pmc_class_init_func { + my ($self) = @_; + my $class_init_code = ""; + + if ($self->has_method('class_init')) { + $class_init_code .= $self->get_method('class_init')->body; + + $class_init_code =~ s/INTERP/interp/g; + + # fix indenting + $class_init_code =~ s/^/ /mg; + $class_init_code = < + +Returns the C code for the PMC's initialization method, or an empty +string if the PMC has a C flag. + +=cut + +sub init_func { + my ($self) = @_; + return '' if $self->no_init; + + my $cout = ''; + my $classname = $self->name; + my $enum_name = $self->is_dynamic ? -1 : "enum_class_$classname"; + my $multi_funcs = $self->find_multi_functions(); + + my @multi_list; + my %strings_seen; + my $multi_strings = ''; + my $cache = {}; + + my $i = 0; + for my $multi (@$multi_funcs) { + my ($name, $ssig, $fsig, $ns, $func) = @$multi; + my ($name_str, $ssig_str, $fsig_str, $ns_name) = + map { gen_multi_name($_, $cache) } ($name, $ssig, $fsig, $ns); + + for my $s ([$name, $name_str], + [$ssig, $ssig_str], + [$fsig, $fsig_str], + [$ns, $ns_name ]) { + my ($raw_string, $name) = @$s; + next if $strings_seen{$name}++; + $multi_strings .= " STRING * const $name = " + . qq|CONST_STRING_GEN(interp, "$raw_string");\n|; + } + + push @multi_list, <{flags}{provides} } ) ); + my $class_init_code = ""; + + if ($self->has_method('class_init')) { + $class_init_code .= " thispmc_class_init(interp, entry);\n"; + } + + my %extra_vt; + $extra_vt{ro} = $self->{ro} if $self->{ro}; + + $cout .= <<"EOC"; +void +Parrot_${classname}_class_init(PARROT_INTERP, int entry, int pass) +{ + static const char attr_defs [] = +EOC + $cout .= ' "'; + + my $attributes = $self->attributes; + foreach my $attribute ( @$attributes ) { + my $attrtype = $attribute->{type}; + my $attrname = $attribute->{name}; + my $typeid = ':'; # Unhandled + if($attrname =~ m/\(*(\w+)\)\(.*?\)/) { + $attrname = $1; + } + elsif ($attrtype eq "INTVAL") { + $typeid = 'I'; + } + elsif ($attrtype eq "FLOATVAL") { + $typeid = 'F'; + } + elsif ($attrtype =~ /STRING\s*\*$/) { + $typeid = 'S'; + } + elsif ($attrtype =~ /PMC\s*\*$/) { + $typeid = 'F'; + } + + $cout .= $typeid; + $cout .= $attrname; + $cout .= ' '; + } + + $cout .= "\";\n"; + + my $const = ( $self->{flags}{dynpmc} ) ? " " : " const "; + + my $flags = $self->vtable_flags; + $cout .= <<"EOC"; + if (pass == 0) { + VTABLE * const vt = Parrot_${classname}_get_vtable(interp); + vt->base_type = $enum_name; + vt->flags = $flags; + vt->attribute_defs = attr_defs; + interp->vtables[entry] = vt; + +EOC + + # init vtable slot + if ( $self->is_dynamic ) { + $cout .= <<"EOC"; + vt->base_type = entry; + vt->whoami = Parrot_str_new_init(interp, "$classname", @{[length($classname)]}, + Parrot_ascii_encoding_ptr, PObj_constant_FLAG|PObj_external_FLAG); + vt->provides_str = Parrot_str_concat(interp, vt->provides_str, + Parrot_str_new_init(interp, "$provides", @{[length($provides)]}, Parrot_ascii_encoding_ptr, + PObj_constant_FLAG|PObj_external_FLAG)); + +EOC + } + else { + $cout .= <<"EOC"; + vt->whoami = CONST_STRING_GEN(interp, "$classname"); + vt->provides_str = CONST_STRING_GEN(interp, "$provides"); +EOC + } + + $cout .= <<"EOC"; + vt->isa_hash = Parrot_${classname}_get_isa(interp, NULL); +EOC + + for my $k ( keys %extra_vt ) { + my $k_flags = $self->$k->vtable_flags; + $cout .= <<"EOC"; + { + VTABLE *vt_$k; + vt_${k} = Parrot_${classname}_${k}_get_vtable(interp); + vt_${k}->base_type = $enum_name; + vt_${k}->flags = $k_flags; + + vt_${k}->attribute_defs = attr_defs; + + vt_${k}->base_type = entry; + vt_${k}->whoami = vt->whoami; + vt_${k}->provides_str = vt->provides_str; + vt->${k}_variant_vtable = vt_${k}; + vt_${k}->${k}_variant_vtable = vt; + vt_${k}->isa_hash = vt->isa_hash; + } + +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 */ + const INTVAL hll_id = Parrot_hll_get_HLL_id( interp, CONST_STRING_GEN(interp, "$hll")); + if (hll_id > 0) { +EOC + foreach my $maps ( sort keys %{ $self->{flags}{maps} } ) { + $cout .= <<"EOC"; + Parrot_hll_register_HLL_type( interp, hll_id, enum_class_$maps, entry); +EOC + } + $cout .= <<"EOC"; + } + } /* Register */ +EOC + } + + $cout .= <<"EOC"; + { + VTABLE * const vt = interp->vtables[entry]; + + vt->mro = Parrot_${classname}_get_mro(interp, PMCNULL); + + if (vt->ro_variant_vtable) + vt->ro_variant_vtable->mro = vt->mro; + } + + /* set up MRO and _namespace */ + Parrot_pmc_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; + + #these differ for METHODs + my $method_name = $method->name; + my $symbol_name = $method->symbol; + my ($pcc_signature) = $method->pcc_signature; + + $cout .= <<"EOC"; + { + STRING *method_name = CONST_STRING_GEN(interp, "$symbol_name"); + STRING *signature = CONST_STRING_GEN(interp, "$pcc_signature"); + register_native_pcc_method_in_ns(interp, entry, + F2DPTR(Parrot_${classname}_${method_name}), + method_name, signature); + } +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 + if ($class_init_code) { + $cout .= <<"EOC"; + + /* class_init */ +$class_init_code + +EOC + } + + $cout .= <<"EOC"; + { +EOC + + + if ( @$multi_funcs ) { + # Don't const the list, breaks some older C compilers + $cout .= $multi_strings . <<"EOC"; + + multi_func_list _temp_multi_func_list[$multi_list_size]; +$multi_list + Parrot_mmd_add_multi_list_from_c_args(interp, + _temp_multi_func_list, $multi_list_size); +EOC + } + + $cout .= <<"EOC"; + } + } /* pass */ +} /* Parrot_${classname}_class_init */ +EOC + + if ( $self->is_dynamic ) { + $cout .= dynext_load_code( $classname, $classname => {} ); + } + + $cout; +} + +=item C + +Returns the C code for the PMC's update_vtable. + +=cut + +sub update_vtable_func { + my ($self) = @_; + + my $cout = ""; + my $classname = $self->name; + my $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_EXPORT'; + + # Sets the attr_size field: + # - If the auto_attrs flag is set, use the current data. + # - If manual_attrs is set, set to 0. + # - If none is set, check if this PMC has init or init_pmc vtable functions, + # setting it to 0 in that case, and keeping the value from the + # parent otherwise. + my $set_attr_size = ''; + my $flag_auto_attrs = $self->{flags}{auto_attrs}; + my $flag_manual_attrs = $self->{flags}{manual_attrs}; + die 'manual_attrs and auto_attrs can not be used together' + . 'in PMC ' . $self->name + if ($flag_auto_attrs && $flag_manual_attrs); + die 'PMC ' . $self->name . ' has attributes but no auto_attrs or manual_attrs' + if (@{$self->attributes} && ! ($flag_auto_attrs || $flag_manual_attrs)); + + if ( @{$self->attributes} && $flag_auto_attrs) { + $set_attr_size .= "sizeof(Parrot_${classname}_attributes)"; + } + else { + $set_attr_size .= "0" if $flag_manual_attrs || + exists($self->{has_method}{init}) || + exists($self->{has_method}{init_pmc}); + } + $set_attr_size = " vt->attr_size = " . $set_attr_size . ";\n" + if $set_attr_size ne ''; + + my $vtable_updates = ''; + for my $name ( @{ $self->vtable->names } ) { + if (exists $self->{has_method}{$name}) { + $vtable_updates .= " vt->$name = Parrot_${classname}_${name};\n"; + } + } + + $vtable_updates .= $set_attr_size; + + $cout .= <<"EOC"; + +$export +VTABLE *Parrot_${classname}_update_vtable(VTABLE *vt) { +$vtable_updates + return vt; +} + +EOC + + # Generate RO vtable for implemented non-updating methods + $vtable_updates = ''; + foreach my $name ( @{ $self->vtable->names} ) { + next unless exists $self->{has_method}{$name}; + if ($self->vtable_method_does_write($name)) { + # If we override constantness status of vtable + if (!$self->vtable->attrs($name)->{write}) { + $vtable_updates .= " vt->$name = Parrot_${classname}_ro_${name};\n"; + } + } + else { + $vtable_updates .= " vt->$name = Parrot_${classname}_${name};\n"; + } + } + + $vtable_updates .= $set_attr_size; + + $cout .= <<"EOC"; + +$export +VTABLE *Parrot_${classname}_ro_update_vtable(ARGMOD(VTABLE *vt)) { +$vtable_updates + return vt; +} + +EOC + + $cout; +} + +=item C + +Returns the C code for the PMC's get_mro function. + +=cut + +sub get_mro_func { + my ($self) = @_; + + my $cout = ""; + my $classname = $self->name; + my $get_mro = ''; + my @parent_names; + my $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_EXPORT'; + + if ($classname ne 'default') { + for my $dp (reverse @{ $self->direct_parents}) { + $get_mro .= " mro = Parrot_${dp}_get_mro(interp, mro);\n" + unless $dp eq 'default'; + } + } + + $cout .= <<"EOC"; +$export +PARROT_CANNOT_RETURN_NULL +PARROT_WARN_UNUSED_RESULT +PMC* Parrot_${classname}_get_mro(PARROT_INTERP, ARGIN_NULLOK(PMC* mro)) { + if (PMC_IS_NULL(mro)) { + mro = Parrot_pmc_new(interp, enum_class_ResizableStringArray); + } +$get_mro + VTABLE_unshift_string(interp, mro, + Parrot_str_new_init(interp, "$classname", @{[length($classname)]}, + Parrot_default_encoding_ptr, 0)); + return mro; +} + +EOC + + $cout; +} + +=item C + +Returns the C code for the PMC's get_isa function. + +=cut + +sub get_isa_func { + my ($self) = @_; + + my $cout = ""; + my $classname = $self->name; + my $get_isa = ''; + my @parent_names; + my $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_EXPORT'; + + if ($classname ne 'default') { + for my $dp (reverse @{ $self->direct_parents}) { + $get_isa .= " isa = Parrot_${dp}_get_isa(interp, isa);\n" + unless $dp eq 'default'; + } + } + + $cout .= <<"EOC"; +$export +PARROT_CANNOT_RETURN_NULL +PARROT_WARN_UNUSED_RESULT +Hash* Parrot_${classname}_get_isa(PARROT_INTERP, ARGIN_NULLOK(Hash* isa)) { +EOC + + if ($get_isa ne '') { + $cout .= $get_isa; + } + else { + $cout .= <<"EOC"; + if (isa == NULL) { + isa = Parrot_hash_new(interp); + } +EOC + } + $cout .= <<"EOC"; + Parrot_hash_put(interp, isa, (void *)(CONST_STRING_GEN(interp, "$classname")), PMCNULL); + return isa; +} + +EOC + + $cout; +} + + +=item C + +Returns the C code for the PMC's update_vtable. + +=cut + +sub get_vtable_func { + my ($self) = @_; + + my $cout = ""; + my $classname = $self->name; + my @other_parents = reverse @{ $self->direct_parents }; + my $first_parent = shift @other_parents; + my $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_EXPORT'; + + my $get_vtable = ''; + + if ($first_parent eq 'default') { + $get_vtable .= " vt = Parrot_default_get_vtable(interp);\n"; + } + else { + $get_vtable .= " vt = Parrot_${first_parent}_get_vtable(interp);\n"; + } + + foreach my $parent_name ( @other_parents) { + $get_vtable .= " Parrot_${parent_name}_update_vtable(vt);\n"; + } + + $get_vtable .= " Parrot_${classname}_update_vtable(vt);\n"; + + $cout .= <<"EOC"; +$export +PARROT_CANNOT_RETURN_NULL +PARROT_WARN_UNUSED_RESULT +VTABLE* Parrot_${classname}_get_vtable(PARROT_INTERP) { + VTABLE *vt; +$get_vtable + return vt; +} + +EOC + + my $get_extra_vtable = ''; + + if ($first_parent eq 'default') { + $get_extra_vtable .= " vt = Parrot_default_ro_get_vtable(interp);\n"; + } + else { + $get_extra_vtable .= " vt = Parrot_${first_parent}_ro_get_vtable(interp);\n"; + } + + foreach my $parent_name ( @other_parents ) { + $get_extra_vtable .= " Parrot_${parent_name}_ro_update_vtable(vt);\n"; + } + + if ($self->is_dynamic) { + # The C could be optimized, but the case when Parrot_x_get_vtable_pointer + # is needed is very rare. See TT #898 for more info. + $cout .= <<"EOC"; +$export +PARROT_CANNOT_RETURN_NULL +PARROT_WARN_UNUSED_RESULT +VTABLE* Parrot_${classname}_get_vtable_pointer(PARROT_INTERP) { + STRING *type_name = Parrot_str_new_constant(interp, "${classname}"); + INTVAL type_num = Parrot_pmc_get_type_str(interp, type_name); + return interp->vtables[type_num]; +} + +EOC + } + + $get_extra_vtable .= " Parrot_${classname}_ro_update_vtable(vt);\n"; + + $cout .= <<"EOC"; +$export +PARROT_CANNOT_RETURN_NULL +PARROT_WARN_UNUSED_RESULT +VTABLE* Parrot_${classname}_ro_get_vtable(PARROT_INTERP) { + VTABLE *vt; +$get_extra_vtable + return vt; +} + +EOC + + $cout; +} + +sub is_vtable_method { + my ( $self, $vt_method_name ) = @_; + return 1 if $self->vtable->has_method($vt_method_name); + return 0; +} + +=item C + +Generate switch-bases VTABLE for MULTI + +=back + +=cut + +sub gen_switch_vtable { + my ($self) = @_; + + # No cookies for DynPMC. At least not now. + return 1 if $self->is_dynamic; + + # Convert list of multis to name->[(type,,ssig,fsig,ns,func)] hash. + my %multi_methods; + foreach (@{$self->find_multi_functions}) { + my ($name, $ssig, $fsig, $ns, $func, $method) = @$_; + my @sig = split /,/, $fsig; + push @{ $multi_methods{ $name } }, [ $sig[1], $ssig, $fsig, $ns, $func, $method ]; + } + + # vtables + foreach my $method ( @{ $self->vtable->methods } ) { + my $vt_method_name = $method->name; + next if $vt_method_name eq 'class_init'; + + next if $self->implements_vtable($vt_method_name); + next unless exists $multi_methods{$vt_method_name}; + + my $multis = $multi_methods{$vt_method_name}; + + # Get parameters. strip type from param + my @parameters = map { s/(\s*\S+\s*\*?\s*)//; $_ } split (/,/, $method->parameters); + + # Gather "case :" + my @cases = map { $self->generate_single_case($vt_method_name, $_, @parameters) } @$multis; + my $cases = join "", @cases; + + my $body = <<"BODY"; + INTVAL type = VTABLE_type(INTERP, $parameters[0]); + /* For dynpmc fallback to MMD */ + if ((type >= enum_class_core_max) || (SELF.type() >= enum_class_core_max)) + type = enum_class_core_max; + switch(type) { +$cases + } +BODY + + my $vtable = $method->clone({ + body => Parrot::Pmc2c::Emitter->text($body), + }); + $self->add_method($vtable); + } + + 1; +} + +# Generate single case for switch VTABLE +sub generate_single_case { + my ($self, $vt_method_name, $multi, @parameters) = @_; + + my ($type, $ssig, $fsig, $ns, $func, $impl) = @$multi; + my $case; + + # Gather parameters names + my $parameters = join ', ', @parameters; + # ISO C forbids return with expression from void functions. + my $return = $impl->return_type =~ /^void\s*$/ + ? '' + : 'return '; + + if ($type eq 'DEFAULT' || $type eq 'PMC') { + # For default case we have to handle return manually. + my ($pcc_signature, $retval, $call_tail, $pcc_return) + = $self->gen_defaul_case_wrapping($ssig, @parameters); + my $dispatch = "Parrot_mmd_multi_dispatch_from_c_args(INTERP, \"$vt_method_name\", \"$pcc_signature\", SELF, $parameters$call_tail);"; + + $case = <<"CASE"; + case enum_class_core_max: +CASE + if ($retval eq '') { + $case .= <<"CASE"; + $dispatch +CASE + } + else { + $case .= <<"CASE"; + { + $retval + $dispatch + $pcc_return + } +CASE + } + $case .= <<"CASE"; + break; + default: + $return$func(INTERP, SELF, $parameters); + break; +CASE + } + else { + $case = <<"CASE"; + case enum_class_$type: + $return$func(INTERP, SELF, $parameters); + break; +CASE + } + + $case; +} + +# Generate (pcc_signature, retval holder, pcc_call_tail, return statement) +# for default case in switch. +sub gen_defaul_case_wrapping { + my ($self, $ssig, @parameters) = @_; + + my $letter = substr($ssig, 0, 1); + if ($letter eq 'I') { + return ( + "PP->" . $letter, + "INTVAL retval;", + ', &retval', + 'return retval;', + ); + } + elsif ($letter eq 'S') { + return ( + "PP->" . $letter, + "STRING *retval;", + ', &retval', + 'return retval;', + ); + } + elsif ($letter eq 'P') { + return ( + 'PPP->P', + 'PMC *retval = PMCNULL;', + ", &retval", + "return retval;", + ); + } + elsif ($letter eq 'v') { + return ( + 'PP->', + '', + '', + 'return;', + ); + } + else { + die "Can't handle signature $ssig!"; + } +} 1; # Local Variables: diff --git a/lib/Parrot/Pmc2c/PMC/RO.pm b/lib/Parrot/Pmc2c/PMC/RO.pm index 27ecd21..94ea217 100644 --- a/lib/Parrot/Pmc2c/PMC/RO.pm +++ b/lib/Parrot/Pmc2c/PMC/RO.pm @@ -25,7 +25,6 @@ use warnings; use base qw( Parrot::Pmc2c::PMC ); use Parrot::Pmc2c::Emitter (); -use Parrot::Pmc2c::PMCEmitter (); use Parrot::Pmc2c::Method (); use Parrot::Pmc2c::UtilFunctions qw( return_statement ); use Text::Balanced 'extract_bracketed'; diff --git a/lib/Parrot/Pmc2c/PMCEmitter.pm b/lib/Parrot/Pmc2c/PMCEmitter.pm deleted file mode 100644 index 66c35da..0000000 --- a/lib/Parrot/Pmc2c/PMCEmitter.pm +++ /dev/null @@ -1,1163 +0,0 @@ -# Copyright (C) 2007-2011, Parrot Foundation. - -=head1 NAME - -Parrot::Pmc2c::PMCEmitter - PMC to C Code Generation - -=head1 SYNOPSIS - - use Parrot::Pmc2c::PMCEmitter; - -=head1 DESCRIPTION - -C is used by F 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( dont_edit dynext_load_code c_code_coda ); -use Text::Balanced 'extract_bracketed'; -use Parrot::Pmc2c::PCCMETHOD (); -use Parrot::Pmc2c::MULTI (); -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(); - - return $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->is_dynamic) ); - - $self->generate_h_file; - $emitter->write_to_file; -} - -=item C - -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 ) ); - if ($self->is_dynamic) { - $c->emit("#define PARROT_IN_EXTENSION\n"); - $c->emit("#define CONST_STRING(i, s) Parrot_str_new_constant((i), s)\n"); - $c->emit("#define CONST_STRING_GEN(i, s) Parrot_str_new_constant((i), s)\n"); - } - - $self->gen_includes; - - # The PCC code needs Continuation-related macros from these headers. - $c->emit("#include \"pmc_continuation.h\"\n"); - $c->emit("#include \"pmc_callcontext.h\"\n"); - - $c->emit( $self->preamble ); - - $c->emit( $self->hdecls ); - $c->emit( $self->{ro}->hdecls ) if ( $self->{ro} ); - $self->gen_methods; - - my $ro = $self->ro; - if ($ro) { - $ro->{emitter} = $self->{emitter}; - $ro->gen_methods; - } - - $c->emit("#include \"pmc_default.h\"\n"); - - $c->emit( $self->update_vtable_func ); - $c->emit( $self->get_vtable_func ); - $c->emit( $self->get_mro_func ); - $c->emit( $self->get_isa_func ); - $c->emit( $self->pmc_class_init_func ); - $c->emit( $self->init_func ); - $c->emit( $self->postamble ); - - return 1; -} - -=item C - -Generates the C header file code for the PMC. - -=cut - -sub generate_h_file { - my ($self) = @_; - my $h = $self->{emitter}; - my $uc_name = uc $self->name; - my $name = $self->name; - - $h->emit( dont_edit( $self->filename ) ); - $h->emit(<<"EOH"); - -#ifndef PARROT_PMC_${uc_name}_H_GUARD -#define PARROT_PMC_${uc_name}_H_GUARD - -EOH - - $h->emit("#define PARROT_IN_EXTENSION\n") if ( $self->is_dynamic ); - - # Emit available functions for work with vtables. - my $export = 'PARROT_EXPORT '; - if ($self->is_dynamic) { - $export = 'PARROT_DYNEXT_EXPORT '; - $h->emit("${export}VTABLE* Parrot_${name}_get_vtable_pointer(PARROT_INTERP);\n"); - $h->emit("${export}void Parrot_${name}_class_init(PARROT_INTERP, int, int);\n"); - } - - if ($name ne 'default') { - $h->emit("${export}VTABLE* Parrot_${name}_update_vtable(ARGMOD(VTABLE*));\n"); - $h->emit("${export}VTABLE* Parrot_${name}_ro_update_vtable(ARGMOD(VTABLE*));\n"); - } - $h->emit("${export}VTABLE* Parrot_${name}_get_vtable(PARROT_INTERP);\n"); - $h->emit("${export}VTABLE* Parrot_${name}_ro_get_vtable(PARROT_INTERP);\n"); - $h->emit("${export}PMC* Parrot_${name}_get_mro(PARROT_INTERP, ARGIN_NULLOK(PMC* mro));\n"); - $h->emit("${export}Hash* Parrot_${name}_get_isa(PARROT_INTERP, ARGIN_NULLOK(Hash* isa));\n"); - - - $self->gen_attributes; - $h->emit(<<"EOH"); - -#endif /* PARROT_PMC_${uc_name}_H_GUARD */ - -EOH - $h->emit( c_code_coda() ); - return 1; -} - -=item C - -Returns the C code function declarations for all the methods for inclusion -in the PMC's C header file. - -=cut - -sub hdecls { - my ($self) = @_; - - my $hout; - my $name = $self->name; - my $lc_name = $self->name; - - # generate decls for all vtables 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); - } - - my $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : ''; - - # class init decl - $hout .= "${export}void Parrot_${name}_class_init(PARROT_INTERP, int, int);\n"; - - $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_EXPORT '; - - $hout .= "${export}VTABLE* Parrot_${lc_name}_update_vtable(ARGMOD(VTABLE*));\n" - unless $name eq 'default'; - - $hout .= "${export}VTABLE* Parrot_${lc_name}_get_vtable(PARROT_INTERP);\n"; - - $hout .= "${export}VTABLE* Parrot_${lc_name}_get_vtable_pointer(PARROT_INTERP);\n" - if ($self->is_dynamic); - - $self->{hdecls} .= $hout; - - return $self->{hdecls}; -} - -=back - -=head2 Instance Methods - -=over - -=item C - -Initializes the instance. - -=cut - -sub init { - my ($self) = @_; - - #!( 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; -} - -=item C - -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 - -Generate switch-bases VTABLE for MULTI - -=cut - -sub pre_method_gen { - my ($self) = @_; - - $self->gen_switch_vtable; - - 1; -} - -=item C - -Returns the C code for the pmc methods. - -=cut - -sub gen_methods { - my ($self) = @_; - - # vtables - 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); - } - } - - # methods - foreach my $method ( @{ $self->methods } ) { - next if $method->is_vtable; - $method->generate_body($self); - } -} - -=item C - -Returns the C code for the attribute struct definition. - -=cut - -sub gen_attributes { - my ($self) = @_; - my $attributes = $self->attributes; - - if ( @{$attributes} ) { - - Parrot::Pmc2c::Attribute::generate_start( $attributes->[0], $self ); - - foreach my $attribute ( @{$attributes} ) { - $attribute->generate_declaration($self); - } - - Parrot::Pmc2c::Attribute::generate_end( $attributes->[0], $self ); - - foreach my $attribute ( @{$attributes} ) { - $attribute->generate_accessor($self); - } - } -} - -=item C - -Returns an arrayref of MULTI function names declared in the PMC. Used to -initialize the multiple dispatch function list. - -=cut - -sub find_multi_functions { - my ($self) = @_; - - my $pmcname = $self->name; - my ( @multi_names ); - - foreach my $method ( @{ $self->methods } ) { - next unless $method->is_multi; - my $short_sig = $method->{MULTI_short_sig}; - my $full_sig = $pmcname . "," . $method->{MULTI_full_sig}; - my $functionname = 'Parrot_' . $pmcname . '_' . $method->name; - push @multi_names, [ $method->symbol, $short_sig, $full_sig, - $pmcname, $functionname, $method ]; - } - return ( \@multi_names ); -} - -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 - -Returns C code to produce a PMC's flags. - -=cut - -sub vtable_flags { - my ($self) = @_; - - my $vtbl_flag = 0; - $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'); - - return $vtbl_flag; -} - -=item C - -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 = $self->vtable_flags; - - 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 = <{$name} if exists $cache->{$name}; - my $count = keys %$cache; - return $cache->{$name} = "mfl_$count"; -} - -=item C - -Returns the C code for the PMC's class_init function as a static -function to be called from the exported class_init. - -=cut - -sub pmc_class_init_func { - my ($self) = @_; - my $class_init_code = ""; - - if ($self->has_method('class_init')) { - $class_init_code .= $self->get_method('class_init')->body; - - $class_init_code =~ s/INTERP/interp/g; - - # fix indenting - $class_init_code =~ s/^/ /mg; - $class_init_code = < - -Returns the C code for the PMC's initialization method, or an empty -string if the PMC has a C flag. - -=cut - -sub init_func { - my ($self) = @_; - return '' if $self->no_init; - - my $cout = ''; - my $classname = $self->name; - my $enum_name = $self->is_dynamic ? -1 : "enum_class_$classname"; - my $multi_funcs = $self->find_multi_functions(); - - my @multi_list; - my %strings_seen; - my $multi_strings = ''; - my $cache = {}; - - my $i = 0; - for my $multi (@$multi_funcs) { - my ($name, $ssig, $fsig, $ns, $func) = @$multi; - my ($name_str, $ssig_str, $fsig_str, $ns_name) = - map { gen_multi_name($_, $cache) } ($name, $ssig, $fsig, $ns); - - for my $s ([$name, $name_str], - [$ssig, $ssig_str], - [$fsig, $fsig_str], - [$ns, $ns_name ]) { - my ($raw_string, $name) = @$s; - next if $strings_seen{$name}++; - $multi_strings .= " STRING * const $name = " - . qq|CONST_STRING_GEN(interp, "$raw_string");\n|; - } - - push @multi_list, <{flags}{provides} } ) ); - my $class_init_code = ""; - - if ($self->has_method('class_init')) { - $class_init_code .= " thispmc_class_init(interp, entry);\n"; - } - - my %extra_vt; - $extra_vt{ro} = $self->{ro} if $self->{ro}; - - $cout .= <<"EOC"; -void -Parrot_${classname}_class_init(PARROT_INTERP, int entry, int pass) -{ - static const char attr_defs [] = -EOC - $cout .= ' "'; - - my $attributes = $self->attributes; - foreach my $attribute ( @$attributes ) { - my $attrtype = $attribute->{type}; - my $attrname = $attribute->{name}; - my $typeid = ':'; # Unhandled - if($attrname =~ m/\(*(\w+)\)\(.*?\)/) { - $attrname = $1; - } - elsif ($attrtype eq "INTVAL") { - $typeid = 'I'; - } - elsif ($attrtype eq "FLOATVAL") { - $typeid = 'F'; - } - elsif ($attrtype =~ /STRING\s*\*$/) { - $typeid = 'S'; - } - elsif ($attrtype =~ /PMC\s*\*$/) { - $typeid = 'F'; - } - - $cout .= $typeid; - $cout .= $attrname; - $cout .= ' '; - } - - $cout .= "\";\n"; - - my $const = ( $self->{flags}{dynpmc} ) ? " " : " const "; - - my $flags = $self->vtable_flags; - $cout .= <<"EOC"; - if (pass == 0) { - VTABLE * const vt = Parrot_${classname}_get_vtable(interp); - vt->base_type = $enum_name; - vt->flags = $flags; - vt->attribute_defs = attr_defs; - interp->vtables[entry] = vt; - -EOC - - # init vtable slot - if ( $self->is_dynamic ) { - $cout .= <<"EOC"; - vt->base_type = entry; - vt->whoami = Parrot_str_new_init(interp, "$classname", @{[length($classname)]}, - Parrot_ascii_encoding_ptr, PObj_constant_FLAG|PObj_external_FLAG); - vt->provides_str = Parrot_str_concat(interp, vt->provides_str, - Parrot_str_new_init(interp, "$provides", @{[length($provides)]}, Parrot_ascii_encoding_ptr, - PObj_constant_FLAG|PObj_external_FLAG)); - -EOC - } - else { - $cout .= <<"EOC"; - vt->whoami = CONST_STRING_GEN(interp, "$classname"); - vt->provides_str = CONST_STRING_GEN(interp, "$provides"); -EOC - } - - $cout .= <<"EOC"; - vt->isa_hash = Parrot_${classname}_get_isa(interp, NULL); -EOC - - for my $k ( keys %extra_vt ) { - my $k_flags = $self->$k->vtable_flags; - $cout .= <<"EOC"; - { - VTABLE *vt_$k; - vt_${k} = Parrot_${classname}_${k}_get_vtable(interp); - vt_${k}->base_type = $enum_name; - vt_${k}->flags = $k_flags; - - vt_${k}->attribute_defs = attr_defs; - - vt_${k}->base_type = entry; - vt_${k}->whoami = vt->whoami; - vt_${k}->provides_str = vt->provides_str; - vt->${k}_variant_vtable = vt_${k}; - vt_${k}->${k}_variant_vtable = vt; - vt_${k}->isa_hash = vt->isa_hash; - } - -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 */ - const INTVAL hll_id = Parrot_hll_get_HLL_id( interp, CONST_STRING_GEN(interp, "$hll")); - if (hll_id > 0) { -EOC - foreach my $maps ( sort keys %{ $self->{flags}{maps} } ) { - $cout .= <<"EOC"; - Parrot_hll_register_HLL_type( interp, hll_id, enum_class_$maps, entry); -EOC - } - $cout .= <<"EOC"; - } - } /* Register */ -EOC - } - - $cout .= <<"EOC"; - { - VTABLE * const vt = interp->vtables[entry]; - - vt->mro = Parrot_${classname}_get_mro(interp, PMCNULL); - - if (vt->ro_variant_vtable) - vt->ro_variant_vtable->mro = vt->mro; - } - - /* set up MRO and _namespace */ - Parrot_pmc_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; - - #these differ for METHODs - my $method_name = $method->name; - my $symbol_name = $method->symbol; - my ($pcc_signature) = $method->pcc_signature; - - $cout .= <<"EOC"; - { - STRING *method_name = CONST_STRING_GEN(interp, "$symbol_name"); - STRING *signature = CONST_STRING_GEN(interp, "$pcc_signature"); - register_native_pcc_method_in_ns(interp, entry, - F2DPTR(Parrot_${classname}_${method_name}), - method_name, signature); - } -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 - if ($class_init_code) { - $cout .= <<"EOC"; - - /* class_init */ -$class_init_code - -EOC - } - - $cout .= <<"EOC"; - { -EOC - - - if ( @$multi_funcs ) { - # Don't const the list, breaks some older C compilers - $cout .= $multi_strings . <<"EOC"; - - multi_func_list _temp_multi_func_list[$multi_list_size]; -$multi_list - Parrot_mmd_add_multi_list_from_c_args(interp, - _temp_multi_func_list, $multi_list_size); -EOC - } - - $cout .= <<"EOC"; - } - } /* pass */ -} /* Parrot_${classname}_class_init */ -EOC - - if ( $self->is_dynamic ) { - $cout .= dynext_load_code( $classname, $classname => {} ); - } - - $cout; -} - -=item C - -Returns the C code for the PMC's update_vtable. - -=cut - -sub update_vtable_func { - my ($self) = @_; - - my $cout = ""; - my $classname = $self->name; - my $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_EXPORT'; - - # Sets the attr_size field: - # - If the auto_attrs flag is set, use the current data. - # - If manual_attrs is set, set to 0. - # - If none is set, check if this PMC has init or init_pmc vtable functions, - # setting it to 0 in that case, and keeping the value from the - # parent otherwise. - my $set_attr_size = ''; - my $flag_auto_attrs = $self->{flags}{auto_attrs}; - my $flag_manual_attrs = $self->{flags}{manual_attrs}; - die 'manual_attrs and auto_attrs can not be used together' - . 'in PMC ' . $self->name - if ($flag_auto_attrs && $flag_manual_attrs); - die 'PMC ' . $self->name . ' has attributes but no auto_attrs or manual_attrs' - if (@{$self->attributes} && ! ($flag_auto_attrs || $flag_manual_attrs)); - - if ( @{$self->attributes} && $flag_auto_attrs) { - $set_attr_size .= "sizeof(Parrot_${classname}_attributes)"; - } - else { - $set_attr_size .= "0" if $flag_manual_attrs || - exists($self->{has_method}{init}) || - exists($self->{has_method}{init_pmc}); - } - $set_attr_size = " vt->attr_size = " . $set_attr_size . ";\n" - if $set_attr_size ne ''; - - my $vtable_updates = ''; - for my $name ( @{ $self->vtable->names } ) { - if (exists $self->{has_method}{$name}) { - $vtable_updates .= " vt->$name = Parrot_${classname}_${name};\n"; - } - } - - $vtable_updates .= $set_attr_size; - - $cout .= <<"EOC"; - -$export -VTABLE *Parrot_${classname}_update_vtable(VTABLE *vt) { -$vtable_updates - return vt; -} - -EOC - - # Generate RO vtable for implemented non-updating methods - $vtable_updates = ''; - foreach my $name ( @{ $self->vtable->names} ) { - next unless exists $self->{has_method}{$name}; - if ($self->vtable_method_does_write($name)) { - # If we override constantness status of vtable - if (!$self->vtable->attrs($name)->{write}) { - $vtable_updates .= " vt->$name = Parrot_${classname}_ro_${name};\n"; - } - } - else { - $vtable_updates .= " vt->$name = Parrot_${classname}_${name};\n"; - } - } - - $vtable_updates .= $set_attr_size; - - $cout .= <<"EOC"; - -$export -VTABLE *Parrot_${classname}_ro_update_vtable(ARGMOD(VTABLE *vt)) { -$vtable_updates - return vt; -} - -EOC - - $cout; -} - -=item C - -Returns the C code for the PMC's get_mro function. - -=cut - -sub get_mro_func { - my ($self) = @_; - - my $cout = ""; - my $classname = $self->name; - my $get_mro = ''; - my @parent_names; - my $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_EXPORT'; - - if ($classname ne 'default') { - for my $dp (reverse @{ $self->direct_parents}) { - $get_mro .= " mro = Parrot_${dp}_get_mro(interp, mro);\n" - unless $dp eq 'default'; - } - } - - $cout .= <<"EOC"; -$export -PARROT_CANNOT_RETURN_NULL -PARROT_WARN_UNUSED_RESULT -PMC* Parrot_${classname}_get_mro(PARROT_INTERP, ARGIN_NULLOK(PMC* mro)) { - if (PMC_IS_NULL(mro)) { - mro = Parrot_pmc_new(interp, enum_class_ResizableStringArray); - } -$get_mro - VTABLE_unshift_string(interp, mro, - Parrot_str_new_init(interp, "$classname", @{[length($classname)]}, - Parrot_default_encoding_ptr, 0)); - return mro; -} - -EOC - - $cout; -} - -=item C - -Returns the C code for the PMC's get_isa function. - -=cut - -sub get_isa_func { - my ($self) = @_; - - my $cout = ""; - my $classname = $self->name; - my $get_isa = ''; - my @parent_names; - my $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_EXPORT'; - - if ($classname ne 'default') { - for my $dp (reverse @{ $self->direct_parents}) { - $get_isa .= " isa = Parrot_${dp}_get_isa(interp, isa);\n" - unless $dp eq 'default'; - } - } - - $cout .= <<"EOC"; -$export -PARROT_CANNOT_RETURN_NULL -PARROT_WARN_UNUSED_RESULT -Hash* Parrot_${classname}_get_isa(PARROT_INTERP, ARGIN_NULLOK(Hash* isa)) { -EOC - - if ($get_isa ne '') { - $cout .= $get_isa; - } - else { - $cout .= <<"EOC"; - if (isa == NULL) { - isa = Parrot_hash_new(interp); - } -EOC - } - $cout .= <<"EOC"; - Parrot_hash_put(interp, isa, (void *)(CONST_STRING_GEN(interp, "$classname")), PMCNULL); - return isa; -} - -EOC - - $cout; -} - - -=item C - -Returns the C code for the PMC's update_vtable. - -=cut - -sub get_vtable_func { - my ($self) = @_; - - my $cout = ""; - my $classname = $self->name; - my @other_parents = reverse @{ $self->direct_parents }; - my $first_parent = shift @other_parents; - my $export = $self->is_dynamic ? 'PARROT_DYNEXT_EXPORT ' : 'PARROT_EXPORT'; - - my $get_vtable = ''; - - if ($first_parent eq 'default') { - $get_vtable .= " vt = Parrot_default_get_vtable(interp);\n"; - } - else { - $get_vtable .= " vt = Parrot_${first_parent}_get_vtable(interp);\n"; - } - - foreach my $parent_name ( @other_parents) { - $get_vtable .= " Parrot_${parent_name}_update_vtable(vt);\n"; - } - - $get_vtable .= " Parrot_${classname}_update_vtable(vt);\n"; - - $cout .= <<"EOC"; -$export -PARROT_CANNOT_RETURN_NULL -PARROT_WARN_UNUSED_RESULT -VTABLE* Parrot_${classname}_get_vtable(PARROT_INTERP) { - VTABLE *vt; -$get_vtable - return vt; -} - -EOC - - my $get_extra_vtable = ''; - - if ($first_parent eq 'default') { - $get_extra_vtable .= " vt = Parrot_default_ro_get_vtable(interp);\n"; - } - else { - $get_extra_vtable .= " vt = Parrot_${first_parent}_ro_get_vtable(interp);\n"; - } - - foreach my $parent_name ( @other_parents ) { - $get_extra_vtable .= " Parrot_${parent_name}_ro_update_vtable(vt);\n"; - } - - if ($self->is_dynamic) { - # The C could be optimized, but the case when Parrot_x_get_vtable_pointer - # is needed is very rare. See TT #898 for more info. - $cout .= <<"EOC"; -$export -PARROT_CANNOT_RETURN_NULL -PARROT_WARN_UNUSED_RESULT -VTABLE* Parrot_${classname}_get_vtable_pointer(PARROT_INTERP) { - STRING *type_name = Parrot_str_new_constant(interp, "${classname}"); - INTVAL type_num = Parrot_pmc_get_type_str(interp, type_name); - return interp->vtables[type_num]; -} - -EOC - } - - $get_extra_vtable .= " Parrot_${classname}_ro_update_vtable(vt);\n"; - - $cout .= <<"EOC"; -$export -PARROT_CANNOT_RETURN_NULL -PARROT_WARN_UNUSED_RESULT -VTABLE* Parrot_${classname}_ro_get_vtable(PARROT_INTERP) { - VTABLE *vt; -$get_extra_vtable - return vt; -} - -EOC - - $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}; -} - -=item C - -Generate switch-bases VTABLE for MULTI - -=cut - -sub gen_switch_vtable { - my ($self) = @_; - - # No cookies for DynPMC. At least not now. - return 1 if $self->is_dynamic; - - # Convert list of multis to name->[(type,,ssig,fsig,ns,func)] hash. - my %multi_methods; - foreach (@{$self->find_multi_functions}) { - my ($name, $ssig, $fsig, $ns, $func, $method) = @$_; - my @sig = split /,/, $fsig; - push @{ $multi_methods{ $name } }, [ $sig[1], $ssig, $fsig, $ns, $func, $method ]; - } - - # vtables - foreach my $method ( @{ $self->vtable->methods } ) { - my $vt_method_name = $method->name; - next if $vt_method_name eq 'class_init'; - - next if $self->implements_vtable($vt_method_name); - next unless exists $multi_methods{$vt_method_name}; - - my $multis = $multi_methods{$vt_method_name}; - - # Get parameters. strip type from param - my @parameters = map { s/(\s*\S+\s*\*?\s*)//; $_ } split (/,/, $method->parameters); - - # Gather "case :" - my @cases = map { $self->generate_single_case($vt_method_name, $_, @parameters) } @$multis; - my $cases = join "", @cases; - - my $body = <<"BODY"; - INTVAL type = VTABLE_type(INTERP, $parameters[0]); - /* For dynpmc fallback to MMD */ - if ((type >= enum_class_core_max) || (SELF.type() >= enum_class_core_max)) - type = enum_class_core_max; - switch(type) { -$cases - } -BODY - - my $vtable = $method->clone({ - body => Parrot::Pmc2c::Emitter->text($body), - }); - $self->add_method($vtable); - } - - 1; -} - -# Generate single case for switch VTABLE -sub generate_single_case { - my ($self, $vt_method_name, $multi, @parameters) = @_; - - my ($type, $ssig, $fsig, $ns, $func, $impl) = @$multi; - my $case; - - # Gather parameters names - my $parameters = join ', ', @parameters; - # ISO C forbids return with expression from void functions. - my $return = $impl->return_type =~ /^void\s*$/ - ? '' - : 'return '; - - if ($type eq 'DEFAULT' || $type eq 'PMC') { - # For default case we have to handle return manually. - my ($pcc_signature, $retval, $call_tail, $pcc_return) - = $self->gen_defaul_case_wrapping($ssig, @parameters); - my $dispatch = "Parrot_mmd_multi_dispatch_from_c_args(INTERP, \"$vt_method_name\", \"$pcc_signature\", SELF, $parameters$call_tail);"; - - $case = <<"CASE"; - case enum_class_core_max: -CASE - if ($retval eq '') { - $case .= <<"CASE"; - $dispatch -CASE - } - else { - $case .= <<"CASE"; - { - $retval - $dispatch - $pcc_return - } -CASE - } - $case .= <<"CASE"; - break; - default: - $return$func(INTERP, SELF, $parameters); - break; -CASE - } - else { - $case = <<"CASE"; - case enum_class_$type: - $return$func(INTERP, SELF, $parameters); - break; -CASE - } - - $case; -} - -# Generate (pcc_signature, retval holder, pcc_call_tail, return statement) -# for default case in switch. -sub gen_defaul_case_wrapping { - my ($self, $ssig, @parameters) = @_; - - my $letter = substr($ssig, 0, 1); - if ($letter eq 'I') { - return ( - "PP->" . $letter, - "INTVAL retval;", - ', &retval', - 'return retval;', - ); - } - elsif ($letter eq 'S') { - return ( - "PP->" . $letter, - "STRING *retval;", - ', &retval', - 'return retval;', - ); - } - elsif ($letter eq 'P') { - return ( - 'PPP->P', - 'PMC *retval = PMCNULL;', - ", &retval", - "return retval;", - ); - } - elsif ($letter eq 'v') { - return ( - 'PP->', - '', - '', - 'return;', - ); - } - else { - die "Can't handle signature $ssig!"; - } -} - - -1; - -# Local Variables: -# mode: cperl -# cperl-indent-level: 4 -# fill-column: 100 -# End: -# vim: expandtab shiftwidth=4: diff --git a/lib/Parrot/Pmc2c/Parser.pm b/lib/Parrot/Pmc2c/Parser.pm index 04e1a7a..461a76a 100644 --- a/lib/Parrot/Pmc2c/Parser.pm +++ b/lib/Parrot/Pmc2c/Parser.pm @@ -1,12 +1,8 @@ -# Copyright (C) 2004-2008, Parrot Foundation. - package Parrot::Pmc2c::Parser; - +# Copyright (C) 2004-2011, Parrot Foundation. use strict; use warnings; - use base qw( Exporter ); - our @EXPORT_OK = qw( parse_pmc extract_balanced ); use Parrot::Pmc2c::PMC (); use Parrot::Pmc2c::Attribute (); @@ -22,12 +18,18 @@ Parrot::Pmc2c::Parser - PMC Parser =head1 SYNOPSIS - use Parrot::Pmc2c::Parser; + use Parrot::Pmc2c::Parser qw( + parse_pmc + extract_balanced + ); =head1 DESCRIPTION -Parrot::Pmc2c::Parser parses a sudo C syntax into a perl hash that is then dumped. +Parrot::Pmc2c::Parser parses a pseudo-C syntax into a perl hash that is then dumped. + +=head1 SUBROUTINES +This package exports two subroutines on request only. =head2 C @@ -51,7 +53,7 @@ Filename of the pmc to parse. B Reference to a Parrot::Pmc2c::PMC object -B Called by C. +B Called by C. =cut diff --git a/lib/Parrot/Pmc2c/UtilFunctions.pm b/lib/Parrot/Pmc2c/UtilFunctions.pm index 04de4f8..1928b28 100644 --- a/lib/Parrot/Pmc2c/UtilFunctions.pm +++ b/lib/Parrot/Pmc2c/UtilFunctions.pm @@ -1,4 +1,4 @@ -# Copyright (C) 2007-2008, Parrot Foundation. +# Copyright (C) 2007-2011, Parrot Foundation. package Parrot::Pmc2c::UtilFunctions; use strict; @@ -11,6 +11,8 @@ our @EXPORT_OK = qw( count_newlines return_statement dont_edit dynext_load_code c_code_coda slurp spew filename args_from_parameter_list passable_args_from_parameter_list + gen_multi_name + trim ); =head1 NAME @@ -19,7 +21,7 @@ Parrot::Pmc2c::UtilFunctions =head1 DESCRIPTION -Various utility functions used in PMC to C transformations. All functionas +Various utility functions used in PMC to C transformations. All functions are exported on request only. =head1 SUBROUTINES @@ -298,6 +300,23 @@ sub filename { $filename =~ s/\.\w+$/.pmc/ if ( $type eq ".pmc" ); return $filename; } + +sub gen_multi_name { + my ($name, $cache) = @_; + + return $cache->{$name} if exists $cache->{$name}; + my $count = keys %$cache; + return $cache->{$name} = "mfl_$count"; +} + +# Perl trim function to remove whitespace from the start and end of the string +sub trim { + my $string = shift; + $string =~ s/^\s+//; + $string =~ s/\s+$//; + return $string; +} + 1; # Local Variables: diff --git a/tools/build/h2inc.pl b/tools/build/h2inc.pl index 07f5267..fee69f0 100644 --- a/tools/build/h2inc.pl +++ b/tools/build/h2inc.pl @@ -1,4 +1,4 @@ -# Copyright (C) 2009, Parrot Foundation. +# Copyright (C) 2011, Parrot Foundation. =head1 NAME @@ -14,6 +14,11 @@ Invoked by F. Imports functions from Parrot::H2inc. perl tools/build/h2inc.pl +Example (from F output): + + /usr/local/bin/perl tools/build/h2inc.pl include/parrot/enums.h \ + lib/Parrot/Pmc2c/PCCMETHOD_BITS.pm + =cut use strict;