[svn:parrot] r38603 - in trunk: lib/Parrot/Pmc2c lib/Parrot/Pmc2c/PMC src/pmc
bacek at svn.parrot.org
bacek at svn.parrot.org
Fri May 8 12:43:48 UTC 2009
Author: bacek
Date: Fri May 8 12:43:47 2009
New Revision: 38603
URL: https://trac.parrot.org/parrot/changeset/38603
Log:
Merge tt631_part3 branch into trunk.
Modified:
trunk/lib/Parrot/Pmc2c/PMC/RO.pm
trunk/lib/Parrot/Pmc2c/PMC/default.pm
trunk/lib/Parrot/Pmc2c/PMCEmitter.pm
trunk/src/pmc/default.pmc
Modified: trunk/lib/Parrot/Pmc2c/PMC/RO.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/PMC/RO.pm Fri May 8 11:18:04 2009 (r38602)
+++ trunk/lib/Parrot/Pmc2c/PMC/RO.pm Fri May 8 12:43:47 2009 (r38603)
@@ -64,77 +64,44 @@
}
foreach my $vt_method ( @{ $self->vtable->methods } ) {
- my $vt_method_name = $vt_method->name;
- if ( $vt_method_name eq 'find_method' ) {
- my $ro_method = Parrot::Pmc2c::Method->new(
- {
- name => $vt_method_name,
- parent_name => $parent->name,
- return_type => $vt_method->return_type,
- parameters => $vt_method->parameters,
- type => Parrot::Pmc2c::Method::VTABLE,
- }
- );
- my $find_method_parent;
- if ( $parent->implements_vtable($vt_method_name) ) {
- $find_method_parent = $parent->name;
- }
- else {
- $find_method_parent = $parent->{super}{$vt_method_name};
+ my $name = $vt_method->name;
+
+ # Generate ro variant only iff we override method constantness with ":write"
+ next unless $parent->{has_method}{$name}
+ && $parent->vtable_method_does_write($name)
+ && !$parent->vtable->attrs($name)->{write};
+
+ # All parameters passed in are shims, because we're
+ # creating an exception-thrower.
+ my @parameters = split( /\s*,\s*/, $vt_method->parameters );
+ @parameters = map { "SHIM($_)" } @parameters;
+
+ my $ro_method = Parrot::Pmc2c::Method->new(
+ {
+ name => $name,
+ parent_name => $parent->name,
+ return_type => $vt_method->return_type,
+ parameters => join( ', ', @parameters ),
+ type => Parrot::Pmc2c::Method::VTABLE,
+ pmc_unused => 1,
}
- # We can't use enum_class_Foo there. $parent can be non-core PMC.
- my $real_findmethod = 'interp->vtables[pmc_type(interp, Parrot_str_new_constant(interp, "' . $find_method_parent . '"))]->find_method';
- my $body = <<"EOC";
- PMC *const method = $real_findmethod(interp, pmc, method_name);
- if (!PMC_IS_NULL(VTABLE_getprop(interp, method, CONST_STRING_GEN(interp, "write"))))
- return PMCNULL;
- else
- return method;
-EOC
- $ro_method->body( Parrot::Pmc2c::Emitter->text($body) );
- $self->add_method($ro_method);
- }
- elsif ( $parent->vtable_method_does_write($vt_method_name) ) {
- # All parameters passed in are shims, because we're
- # creating an exception-thrower.
- my @parameters = split( /\s*,\s*/, $vt_method->parameters );
- @parameters = map { "SHIM($_)" } @parameters;
-
- my $ro_method = Parrot::Pmc2c::Method->new(
- {
- name => $vt_method_name,
- parent_name => $parent->name,
- return_type => $vt_method->return_type,
- parameters => join( ', ', @parameters ),
- type => Parrot::Pmc2c::Method::VTABLE,
- pmc_unused => 1,
- }
- );
- my $pmcname = $parent->name;
- my $ret = return_statement($ro_method);
- my $body = <<EOC;
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_WRITE_TO_CONSTCLASS,
- "$vt_method_name() in read-only instance of $pmcname");
+ );
+ my $pmcname = $parent->name;
+ my $ret = return_statement($ro_method);
+ my $body = <<EOC;
+Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_WRITE_TO_CONSTCLASS,
+ "$name() in read-only instance of $pmcname");
EOC
- # don't return after a Parrot_ex_throw_from_c_args
- $ro_method->body( Parrot::Pmc2c::Emitter->text($body) );
- $self->add_method($ro_method);
- }
- else {
- if ( $parent->implements_vtable($vt_method_name) ) {
- my $parent_method = $parent->get_method($vt_method_name);
- $self->{super}{$vt_method_name} = $parent_method->parent_name;
- }
- else {
- $self->{super}{$vt_method_name} = $parent->{super}{$vt_method_name};
- }
- }
+ # don't return after a Parrot_ex_throw_from_c_args
+ $ro_method->body( Parrot::Pmc2c::Emitter->text($body) );
+ $self->add_method($ro_method);
}
return $self;
}
+
1;
# Local Variables:
Modified: trunk/lib/Parrot/Pmc2c/PMC/default.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/PMC/default.pm Fri May 8 11:18:04 2009 (r38602)
+++ trunk/lib/Parrot/Pmc2c/PMC/default.pm Fri May 8 12:43:47 2009 (r38603)
@@ -26,27 +26,65 @@
foreach my $method ( @{ $self->vtable->methods } ) {
my $vt_method_name = $method->name;
next unless $self->unimplemented_vtable($vt_method_name);
- my $new_default_method = $method->clone(
- {
- parent_name => $self->name,
- type => Parrot::Pmc2c::Method::VTABLE,
- }
- );
- my $ret = return_statement($method);
-
- # take care to mark the parameters as unused
- # to avoid compiler warnings
- my $body;
- foreach my $param (split /,\s*/, $method->parameters) {
- $param =~ s/.*\b(\w+)/$1/;
- $body .= " UNUSED($param)\n";
+ $self->add_method($self->_generate_default_method($self, $method, 'cant_do_method'));
+ }
+ return 1;
+}
+
+sub gen_methods {
+ my ($self) = @_;
+
+ $self->SUPER::gen_methods;
+
+ # Generate RO variants.
+ my $ro = Parrot::Pmc2c::PMC::RO->new($self);
+ $ro->{emitter} = $self->{emitter};
+ foreach my $method ( @{ $self->vtable->methods } ) {
+ my $vt_method_name = $method->name;
+ if ($vt_method_name eq 'find_method') {
+ # Generate default_ro_find_method.
+ $self->{emitter}->emit(<<'EOC');
+static PMC *
+Parrot_default_ro_find_method(PARROT_INTERP, PMC *pmc, STRING *method_name) {
+ /* Use non-readonly find_method. Current vtable is ro variant. So ro_variant contains non-ro variant */
+ PMC *const method = pmc->vtable->ro_variant_vtable->find_method(interp, pmc, method_name);
+ if (!PMC_IS_NULL(VTABLE_getprop(interp, method, CONST_STRING_GEN(interp, "write"))))
+ return PMCNULL;
+ else
+ return method;
+}
+EOC
+ }
+ if ( $self->vtable_method_does_write($vt_method_name) ) {
+ my $m = $self->_generate_default_method($ro, $method, 'cant_do_write_method');
+ $m->generate_body($ro);
}
- $body .= qq{ cant_do_method(interp, pmc, "$vt_method_name");\n};
+ }
+}
- $new_default_method->body( Parrot::Pmc2c::Emitter->text($body));
- $self->add_method($new_default_method);
+sub _generate_default_method {
+ my ($self, $pmc, $method, $stub_func) = @_;
+
+ my $clone = $method->clone(
+ {
+ parent_name => $self->name,
+ type => Parrot::Pmc2c::Method::VTABLE,
+ }
+ );
+
+ # take care to mark the parameters as unused
+ # to avoid compiler warnings
+ my $body;
+ foreach my $param (split /,\s*/, $method->parameters) {
+ $param =~ s/.*\b(\w+)/$1/;
+ $body .= " UNUSED($param)\n";
}
- return 1;
+ my $vt_method_name = $method->name;
+ $body .= qq{ $stub_func(interp, pmc, "$vt_method_name");\n};
+
+ $clone->body( Parrot::Pmc2c::Emitter->text($body));
+
+ $clone;
}
sub update_vtable_func {
@@ -74,6 +112,27 @@
EOC
+ # Generate RO version of default VTABLE.
+ my $ro_vtable_decl = '';
+ foreach my $name ( @{ $self->vtable->names } ) {
+ if ($self->vtable_method_does_write($name) || ($name eq 'find_method')) {
+ $ro_vtable_decl .= " vt->$name = Parrot_default_ro_${name};\n";
+ }
+ }
+
+ $cout .= <<"EOC";
+
+PARROT_EXPORT VTABLE* Parrot_default_ro_get_vtable(PARROT_INTERP) {
+
+ VTABLE * vt = Parrot_default_get_vtable(interp);
+
+$ro_vtable_decl
+
+ return vt;
+}
+
+EOC
+
$cout;
}
Modified: trunk/lib/Parrot/Pmc2c/PMCEmitter.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/PMCEmitter.pm Fri May 8 11:18:04 2009 (r38602)
+++ trunk/lib/Parrot/Pmc2c/PMCEmitter.pm Fri May 8 12:43:47 2009 (r38603)
@@ -827,28 +827,29 @@
EOC
- my %extra_vt;
- $extra_vt{ro} = $self->{ro} if $self->{ro};
-
- for my $k (keys %extra_vt) {
-
- my $vtable_updates = '';
- foreach my $vt_method ( @{ $self->$k->vtable->names} ) {
-
- next unless ($self->$k->implements_vtable($vt_method));
-
- $vtable_updates .= " vt->$vt_method = Parrot_${classname}_${k}_${vt_method};\n";
+ # 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";
+ }
+ }
- $cout .= <<"EOC";
+ $cout .= <<"EOC";
-PARROT_EXPORT VTABLE *Parrot_${classname}_${k}_update_vtable(VTABLE *vt) {
+PARROT_EXPORT VTABLE *Parrot_${classname}_ro_update_vtable(VTABLE *vt) {
$vtable_updates
return vt;
}
EOC
- }
$cout;
}
@@ -885,31 +886,25 @@
EOC
- my %extra_vt;
- $extra_vt{ro} = $self->{ro} if $self->{ro};
-
- for my $k (keys %extra_vt) {
- my $get_extra_vtable = '';
- foreach my $parent_name ( reverse ($self->name, @{ $self->parents }) ) {
- if ($parent_name eq 'default') {
- $get_extra_vtable .= " vt = Parrot_default_get_vtable(interp);\n";
- }
- else {
- $get_extra_vtable .= " Parrot_${parent_name}_update_vtable(vt);\n";
- $get_extra_vtable .= " Parrot_${parent_name}_${k}_update_vtable(vt);\n";
- }
+ my $get_extra_vtable = '';
+ foreach my $parent_name ( reverse ($self->name, @{ $self->parents }) ) {
+ if ($parent_name eq 'default') {
+ $get_extra_vtable .= " vt = Parrot_default_ro_get_vtable(interp);\n";
}
+ else {
+ $get_extra_vtable .= " Parrot_${parent_name}_ro_update_vtable(vt);\n";
+ }
+ }
- $cout .= <<"EOC";
+ $cout .= <<"EOC";
PARROT_EXPORT
-VTABLE* Parrot_${classname}_${k}_get_vtable(PARROT_INTERP) {
+VTABLE* Parrot_${classname}_ro_get_vtable(PARROT_INTERP) {
VTABLE *vt;
$get_extra_vtable
return vt;
}
EOC
- }
$cout;
}
Modified: trunk/src/pmc/default.pmc
==============================================================================
--- trunk/src/pmc/default.pmc Fri May 8 11:18:04 2009 (r38602)
+++ trunk/src/pmc/default.pmc Fri May 8 12:43:47 2009 (r38603)
@@ -68,6 +68,28 @@
caller(interp, pmc));
}
+
+/*
+
+=item C<static void cant_do_write_method(PARROT_INTERP, PMC *pmc,
+ const char *methname)>
+
+Throws an exception "$methname() on read-only instance of '$class'", used by
+all updating messages on read-only instances.
+
+=cut
+
+*/
+
+PARROT_DOES_NOT_RETURN
+static void
+cant_do_write_method(PARROT_INTERP, PMC *pmc /*NULLOK*/, const char *methname)
+{
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_WRITE_TO_CONSTCLASS,
+ "%s() in read-only instance of '%Ss'", methname,
+ caller(interp, pmc));
+}
+
/*
=item C<static INTVAL
More information about the parrot-commits
mailing list