# Copyright (C) 2004-2007, The Perl Foundation.
# $Id: PCCMETHOD.pm 23916 2007-12-15 08:38:45Z chromatic $
package Parrot::Pmc2c::PCCMETHOD;
use strict;
use warnings;
use Carp qw(longmess croak);
=head1 NAME
Parrot::Pmc2c::PCCMETHOD - Parses and preps PMC PCCMETHOD called from F<Parrot:Pmc2c::Pmc2cMain>
=head1 SYNOPSIS
use Parrot::Pmc2c::PCCMETHOD;
=head1 DESCRIPTION
Parrot::Pmc2c::PCCMETHOD - Parses and preps PMC PCCMETHOD called from F<Parrot:Pmc2c::Pmc2cMain>
=cut
=head1 FUNCTIONS
=head2 Publicly Available Methods
=head3 C<rewrite_pccmethod($method, $pmc)>
B<Purpose:> Parse and Build PMC PCCMETHODS.
B<Arguments:>
=over 4
=item * C<self>
=item * C<method>
Current Method Object
=item * C<body>
Current Method Body
=back
=head3 C<rewrite_pccinvoke($method, $pmc)>
B<Purpose:> Parse and Build a PCCINVOKE Call.
B<Arguments:>
=over 4
=item * C<self>
=item * C<method>
Current Method Object
=item * C<body>
Current Method Body
=back
=cut
use constant REGNO_INT => 0;
use constant REGNO_NUM => 1;
use constant REGNO_STR => 2;
use constant REGNO_PMC => 3;
# refactor to a simple module import, RT#42286
BEGIN {
my $bits = 'Parrot/Pmc2c/PCCMETHOD_BITS.pl';
my %consts = do $bits;
unless (%consts) {
die $@ if $@;
die "$bits: $!";
}
require constant;
while ( my ( $k, $v ) = each %consts ) {
constant->import( $k, $v );
}
}
=head3
regtype to argtype conversion hash
=cut
our $reg_type_info = {
# s is string, ss is short string, at is arg type
+(REGNO_INT) => { s => "INTVAL", ss => "INT", at => PARROT_ARG_INTVAL, },
+(REGNO_NUM) => { s => "FLOATVAL", ss => "NUM", at => PARROT_ARG_FLOATVAL, },
+(REGNO_STR) => { s => "STRING*", ss => "STR", at => PARROT_ARG_STRING, },
+(REGNO_PMC) => { s => "PMC*", ss => "PMC", at => PARROT_ARG_PMC, },
};
# Declare the subroutines
sub trim($);
sub ltrim($);
sub rtrim($);
# 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<parse_adverb_attributes>
builds and returs an adverb hash from an adverb string such as
":optional :optflag :slurpy"
{
optional =>1,
optflag =>1,
slurpy =>1,
}
=cut
sub parse_adverb_attributes {
my $adverb_string = shift;
my %result;
if ( defined $adverb_string ) {
++$result{$1} while $adverb_string =~ /:(\S+)/g;
}
return \%result;
}
sub convert_type_string_to_reg_type {
($_) = @_;
return REGNO_INT if /INTVAL|int/i;
return REGNO_NUM if /FLOATVAL|double/i;
return REGNO_STR if /STRING/i;
return REGNO_PMC if /PMC/i;
croak "$_ not recognized as INTVAL, FLOATVAL, STRING, or PMC";
}
sub gen_arg_flags {
my ($param) = @_;
return PARROT_ARG_INTVAL | PARROT_ARG_OPT_FLAG if exists $param->{attrs}->{opt_flag};
my $flag = $reg_type_info->{ $param->{type} }->{at};
$flag |= PARROT_ARG_CONSTANT if exists $param->{attrs}->{constant};
$flag |= PARROT_ARG_OPTIONAL if exists $param->{attrs}->{optional};
$flag |= PARROT_ARG_FLATTEN if exists $param->{attrs}->{flatten};
$flag |= PARROT_ARG_SLURPY_ARRAY if exists $param->{attrs}->{slurpy};
$flag |= PARROT_ARG_NAME if exists $param->{attrs}->{name};
$flag |= PARROT_ARG_NAME if exists $param->{attrs}->{named};
return $flag;
}
sub gen_arg_accessor {
my ( $arg, $arg_type ) = @_;
my ( $name, $reg_type, $index ) = ( $arg->{name}, $arg->{type}, $arg->{index} );
my $tis = $reg_type_info->{$reg_type}->{s}; #reg_type_info string
my $tiss = $reg_type_info->{$reg_type}->{ss}; #reg_type_info short string
if ( 'arg' eq $arg_type ) {
return " $tis $name = CTX_REG_$tiss(ctx, $index);\n";
}
elsif ( 'result' eq $arg_type ) {
return " $name = CTX_REG_$tiss(ctx, $index);\n";
}
elsif ( 'name' eq $arg_type ) {
return " CTX_REG_$tiss(ctx, $index) = CONST_STRING(interp, $name);\n";
}
else { #$arg_type eq 'param' or $arg_type eq 'return'
return " CTX_REG_$tiss(ctx, $index) = $name;\n";
}
}
=head3 C<rewrite_PCCRETURNs($method, $pmc)>
Rewrites the method body performing the various macro substitutions for PCCRETURNs.
=cut
sub rewrite_PCCRETURNs {
my ( $self, $pmc ) = @_;
my $method_name = $self->name;
my $body = $self->body;
my $regs_used = [];
my $qty_returns = 0;
my $signature_re = qr{
(PCCRETURN #method name
\s* #optional whitespace
\( ([^\(]*) \) #returns ( stuff ... )
;?) #optional semicolon
}sx;
croak "return not allowed in pccmethods, use PCCRETURN instead $body"
if ( $body and $body =~ m/\breturn\b/ );
while ($body) {
my $matched = undef;
if ($body) {
$matched = $body->find($signature_re);
last unless $matched;
}
$qty_returns++;
$matched =~ /$signature_re/;
my ( $match, $returns ) = ( $1, $2 );
my $goto_string = "goto ${method_name}_returns;";
my ( $returns_n_regs_used, $returns_indexes, $returns_flags, $returns_accessors ) =
process_pccmethod_args( parse_p_args_string($returns), 'return' );
$returns_indexes = "0" unless $returns_indexes;
push @$regs_used, $returns_n_regs_used;
my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename );
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
{
/*BEGIN PCCRETURN $returns */
/*BEGIN GENERATED ACCESSORS */
END
$e->emit(<<"END");
$returns_accessors
END
my $returns_sig = make_arg_pmc($returns_flags, 'return_sig');
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
/*END GENERATED ACCESSORS */
{
opcode_t temp_return_indexes[] = { $returns_indexes };
return_indexes = temp_return_indexes;
}
return_sig = pmc_new(interp, enum_class_FixedIntegerArray);
$returns_sig
$goto_string
/*END PCCRETURN $returns */
}
END
$matched->replace( $match, $e );
}
return $regs_used, $qty_returns;
}
sub parse_p_args_string {
my ($parameters) = @_;
my $linear_args = [];
for my $x ( split /,/, $parameters ) {
my ( $type, $name, $rest ) = split / /, trim($x), 3;
if ( !defined($name) ) {
die "invalid PCC arg '$x': did you forget to specify a type?\n";
}
$name =~ /[\**]?(\"?[\w_]+\"?)/;
my $arg = {
type => convert_type_string_to_reg_type($type),
name => $1,
attrs => parse_adverb_attributes($rest)
};
push @$linear_args, $arg;
}
$linear_args;
}
sub is_named {
my ($arg) = @_;
while ( my ( $k, $v ) = each( %{ $arg->{attrs} } ) ) {
return ( 1, $1 ) if ( $k =~ /named\[(.*)\]/ );
}
return ( 0, '' );
}
sub process_pccmethod_args {
my ( $linear_args, $arg_type ) = @_;
my $n_regs_used_a = [ 0, 0, 0, 0 ]; # INT, FLOAT, STRING, PMC
my $args = [ [], [], [], [] ]; # actual INT, FLOAT, STRING, PMC arg stuctures
my $args_indexes_a = []; # arg index into the interpreter context
my $args_flags_a = []; # arg flags
my $args_accessors = "";
my $named_names = "";
for my $arg (@$linear_args) {
my ( $named, $named_name ) = is_named($arg);
if ($named) {
my $argn = {
type => +(REGNO_STR),
name => $named_name,
};
$arg->{named_arg} = $argn;
$arg->{named_name} = $named_name;
push @{ $args->[ +(REGNO_STR) ] }, $argn;
$argn->{index} = $n_regs_used_a->[ +(REGNO_STR) ]++;
push @$args_indexes_a, $argn->{index};
push @$args_flags_a, PARROT_ARG_STRING | PARROT_ARG_NAME;
$named_names .= gen_arg_accessor( $argn, 'name' );
}
push @{ $args->[ $arg->{type} ] }, $arg;
$arg->{index} = $n_regs_used_a->[ $arg->{type} ]++;
push @$args_indexes_a, $arg->{index};
push @$args_flags_a, gen_arg_flags($arg);
$args_accessors .= gen_arg_accessor( $arg, $arg_type );
}
my $n_regs_used = join( ", ", @$n_regs_used_a );
my $args_indexes = join( ", ", @$args_indexes_a );
return ( $n_regs_used_a, $args_indexes, $args_flags_a, $args_accessors, $named_names );
}
sub find_max_regs {
my ($n_regs) = @_;
my $n_regs_used = [ 0, 0, 0, 0 ];
for my $x (@$n_regs) {
for my $i ( 0 .. 3 ) {
$n_regs_used->[$i] = $n_regs_used->[$i] > $x->[$i] ? $n_regs_used->[$i] : $x->[$i];
}
}
return join( ", ", @$n_regs_used );
}
=head3 C<rewrite_pccmethod()>
rewrite_pccmethod($method, $pmc);
=cut
sub rewrite_pccmethod {
my ( $self, $pmc ) = @_;
my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename );
my $e_post = Parrot::Pmc2c::Emitter->new( $pmc->filename );
# parse pccmethod parameters, then unshift the a PMC arg for the invocant
my $linear_args = parse_p_args_string( $self->parameters );
unshift @$linear_args,
{
type => convert_type_string_to_reg_type('PMC'),
name => 'pmc',
attrs => parse_adverb_attributes(':object')
};
my ( $params_n_regs_used, $params_indexes, $params_flags, $params_accessors, $named_names ) =
process_pccmethod_args( $linear_args, 'arg' );
my ( $n_regs, $qty_returns ) = rewrite_PCCRETURNs( $self, $pmc );
rewrite_pccinvoke( $self, $pmc );
unshift @$n_regs, $params_n_regs_used;
my $n_regs_used = find_max_regs($n_regs);
my $set_params = make_arg_pmc($params_flags, 'param_sig');
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
INTVAL n_regs_used[] = { $n_regs_used };
opcode_t param_indexes[] = { $params_indexes };
opcode_t *return_indexes;
opcode_t *current_args;
PMC *param_sig = pmc_new(interp, enum_class_FixedIntegerArray);
PMC *return_sig = PMCNULL;
parrot_context_t *caller_ctx = CONTEXT(interp->ctx);
PMC *ret_cont = new_ret_continuation_pmc(interp, NULL);
parrot_context_t *ctx = Parrot_push_context(interp, n_regs_used);
PMC *ccont = PMCNULL;
$set_params
if (caller_ctx) {
ccont = caller_ctx->current_cont;
}
else {
/* there is no point calling real_exception here, because
PDB_backtrace can't deal with a missing to_ctx either. */
internal_exception(1, "No caller_ctx for continuation \%p.", ccont);
}
ctx->current_cont = ret_cont;
PMC_cont(ret_cont)->from_ctx = ctx;
current_args = interp->current_args;
interp->current_args = NULL;
END
$e->emit(<<"END");
$named_names
END
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
interp->params_signature = param_sig;
parrot_pass_args(interp, caller_ctx, ctx, current_args, param_indexes,
PARROT_PASS_PARAMS);
if (PObj_get_FLAGS(ccont) & SUB_FLAG_TAILCALL) {
PObj_get_FLAGS(ccont) &= ~SUB_FLAG_TAILCALL;
--ctx->recursion_depth;
ctx->caller_ctx = caller_ctx->caller_ctx;
Parrot_free_context(interp, caller_ctx, 0);
interp->current_args = NULL;
}
/* BEGIN PARMS SCOPE */
{
END
$e->emit(<<"END");
$params_accessors
END
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
/* BEGIN PMETHOD BODY */
{
END
my $method_returns = $self->name . "_returns:";
$e_post->emit( <<"END", __FILE__, __LINE__ + 1 );
}
goto no_return;
/* END PMETHOD BODY */
END
if ($qty_returns) {
$e_post->emit( <<"END", __FILE__, __LINE__ + 1 );
$method_returns
if (! caller_ctx) {
/* there is no point calling real_exception here, because
PDB_backtrace can't deal with a missing to_ctx either. */
internal_exception(1, "No caller_ctx for continuation \%p.", ccont);
}
interp->returns_signature = return_sig;
parrot_pass_args(interp, ctx, caller_ctx, return_indexes,
caller_ctx->current_results, PARROT_PASS_RESULTS);
END
}
$e_post->emit( <<"END", __FILE__, __LINE__ + 1 );
/* END PARAMS SCOPE */
}
no_return:
PObj_live_CLEAR(param_sig);
PObj_live_CLEAR(return_sig);
Parrot_pop_context(interp);
END
$self->return_type('void');
$self->parameters('');
my $e_body = Parrot::Pmc2c::Emitter->new( $pmc->filename );
$e_body->emit($e);
$e_body->emit( $self->body );
$e_body->emit($e_post);
$self->body($e_body);
$self->{PCCMETHOD} = 1;
return 1;
}
sub isquoted {
1;
}
sub rewrite_pccinvoke {
my ( $method, $pmc ) = @_;
my $body = $method->body;
my $signature_re = qr{
(
(
\( ([^\(]*) \) #results
\s* #optional whitespace
= #results equals PCCINVOKE invocation
\s* #optional whitespace
)? #results are optional
PCCINVOKE #method name
\s* #optional whitespace
\( ([^\(]*) \) #parameters
;? #optional semicolon
)
}sx;
while ($body) {
my $matched = undef;
if ($body) {
$matched = $body->find($signature_re);
last unless $matched;
}
$matched =~ /$signature_re/;
my ( $match, $result_clause, $results, $parameters ) = ( $1, $2, $3, $4 );
#optional results portion of pccinvoke statement
my ( $result_n_regs_used, $result_indexes, $result_flags, $result_accessors ) =
( defined $results )
? process_pccmethod_args( parse_p_args_string($results), 'result' )
: ( [ 0, 0, 0, 0 ], "0", [], "" );
#parameters portion of pccinvoke statement
my ( $interp, $invocant, $method_name, $arguments ) =
map { $_ = trim($_) } split( /,/, $parameters, 4 );
$arguments = "PMC* $invocant" . ( $arguments ? ", $arguments" : "" );
my ( $args_n_regs_used, $arg_indexes, $arg_flags, $arg_accessors, $named_names ) =
process_pccmethod_args( parse_p_args_string($arguments), 'param' );
my $n_regs_used = find_max_regs( [ $result_n_regs_used, $args_n_regs_used ] );
$method_name = "string_from_literal(interp, $method_name)"
if isquoted($method_name);
my $args_set = make_arg_pmc($arg_flags, 'args_sig');
my $results_set = make_arg_pmc($result_flags, 'results_sig');
my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename );
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
/*BEGIN PCCINVOKE $invocant */
{
INTVAL n_regs_used[] = { $n_regs_used };
opcode_t arg_indexes[] = { $arg_indexes };
opcode_t result_indexes[] = { $result_indexes };
PMC *args_sig = pmc_new(interp, enum_class_FixedIntegerArray);
PMC *results_sig = pmc_new(interp, enum_class_FixedIntegerArray);
PMC *ret_cont = new_ret_continuation_pmc(interp, NULL);
parrot_context_t *ctx = Parrot_push_context(interp, n_regs_used);
PMC *pccinvoke_meth;
opcode_t *save_current_args = interp->current_args;
PMC *save_args_signature = interp->args_signature;
PMC *save_current_object = interp->current_object;
$args_set
$results_set
interp->current_args = arg_indexes;
interp->args_signature = args_sig;
ctx->current_results = result_indexes;
ctx->results_signature = results_sig;
END
$e->emit(<<"END");
$named_names
$arg_accessors
END
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
interp->current_object = $invocant;
interp->current_cont = NEED_CONTINUATION;
ctx->current_cont = ret_cont;
PMC_cont(ret_cont)->from_ctx = ctx;
pccinvoke_meth = VTABLE_find_method(interp, $invocant, $method_name);
if (PMC_IS_NULL(pccinvoke_meth)) {
real_exception(interp, NULL, METH_NOT_FOUND,
"Method '%Ss' not found", $method_name);
}
else
VTABLE_invoke(interp, pccinvoke_meth, NULL);
END
$e->emit(<<"END");
$result_accessors
END
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
PObj_live_CLEAR(args_sig);
PObj_live_CLEAR(results_sig);
Parrot_pop_context(interp);
interp->current_args = save_current_args;
interp->args_signature = save_args_signature;
interp->current_object = save_current_object;
}
/*END PCCINVOKE $method_name */
END
$matched->replace( $match, $e );
}
return 1;
}
sub make_arg_pmc {
my ($args, $name) = @_;
return '' unless @$args;
my $code = " VTABLE_set_integer_native(interp, $name, " . @$args
. ");\n";
for my $i ( 0 .. $#{$args} ) {
$code .= " VTABLE_set_integer_keyed_int(interp, $name, "
. "$i, $args->[$i]);\n";
}
return $code;
}
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