[svn:parrot] r38240 - in branches/pcc_rewiring: lib/Parrot/Pmc2c src/call
allison at svn.parrot.org
allison at svn.parrot.org
Mon Apr 20 23:56:40 UTC 2009
Author: allison
Date: Mon Apr 20 23:56:39 2009
New Revision: 38240
URL: https://trac.parrot.org/parrot/changeset/38240
Log:
[pcc] Convert PCCMETHODs over to new calling convention internals.
Modified:
branches/pcc_rewiring/lib/Parrot/Pmc2c/PCCMETHOD.pm
branches/pcc_rewiring/src/call/pcc.c
Modified: branches/pcc_rewiring/lib/Parrot/Pmc2c/PCCMETHOD.pm
==============================================================================
--- branches/pcc_rewiring/lib/Parrot/Pmc2c/PCCMETHOD.pm Mon Apr 20 22:15:54 2009 (r38239)
+++ branches/pcc_rewiring/lib/Parrot/Pmc2c/PCCMETHOD.pm Mon Apr 20 23:56:39 2009 (r38240)
@@ -79,10 +79,22 @@
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, },
+ +(REGNO_INT) => { s => "INTVAL",
+ ss => "INT",
+ pcc => 'I',
+ at => PARROT_ARG_INTVAL},
+ +(REGNO_NUM) => { s => "FLOATVAL",
+ ss => "NUM",
+ pcc => "N",
+ at => PARROT_ARG_FLOATVAL, },
+ +(REGNO_STR) => { s => "STRING*",
+ ss => "STR",
+ pcc => "S",
+ at => PARROT_ARG_STRING, },
+ +(REGNO_PMC) => { s => "PMC*",
+ ss => "PMC",
+ pcc => "P",
+ at => PARROT_ARG_PMC, },
};
# Perl trim function to remove whitespace from the start and end of the string
@@ -110,10 +122,10 @@
=head3 C<parse_adverb_attributes>
builds and returs an adverb hash from an adverb string such as
- ":optional :optflag :slurpy"
+ ":optional :opt_flag :slurpy"
{
optional =>1,
- optflag =>1,
+ opt_flag =>1,
slurpy =>1,
}
@@ -137,6 +149,26 @@
croak "$_ not recognized as INTVAL, FLOATVAL, STRING, or PMC";
}
+sub gen_arg_pcc_sig {
+ my ($param) = @_;
+
+ return 'Ip'
+ if exists $param->{attrs}{opt_flag};
+
+ my $sig = $reg_type_info->{ $param->{type} }->{pcc};
+ $sig .= 'c' if exists $param->{attrs}{constant};
+ $sig .= 'f' if exists $param->{attrs}{flatten};
+ $sig .= 'i' if exists $param->{attrs}{invocant};
+ $sig .= 'l' if exists $param->{attrs}{lookahead};
+ $sig .= 'n' if (exists $param->{attrs}{name} ||
+ exists $param->{attrs}{named});
+ $sig .= 'o' if exists $param->{attrs}{optional};
+ $sig .= 'p' if exists $param->{attrs}{opt_flag};
+ $sig .= 's' if exists $param->{attrs}{slurpy};
+
+ return $sig;
+}
+
sub gen_arg_flags {
my ($param) = @_;
@@ -162,14 +194,11 @@
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";
+ 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_GEN(interp, $name);\n";
- }
else { #$arg_type eq 'param' or $arg_type eq 'return'
return " CTX_REG_$tiss(_ctx, $index) = $name;\n";
}
@@ -185,8 +214,6 @@
my ( $self, $pmc ) = @_;
my $method_name = $self->name;
my $body = $self->body;
- my $regs_used = [];
- my $qty_returns = 0;
my $signature_re = qr{
(RETURN #method name
@@ -206,7 +233,6 @@
last unless $matched;
}
- $qty_returns++;
$matched =~ /$signature_re/;
my ( $match, $returns ) = ( $1, $2 );
@@ -215,7 +241,8 @@
if ($returns eq 'void') {
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
/*BEGIN RETURN $returns */
- goto no_return;
+ Parrot_pop_context(interp);
+ return;
/*END RETURN $returns */
END
$matched->replace( $match, $e );
@@ -223,40 +250,24 @@
}
my $goto_string = "goto ${method_name}_returns;";
- my ( $returns_n_regs_used, $returns_indexes, $returns_flags, $returns_accessors ) =
+ my ( $returns_signature, $returns_varargs ) =
process_pccmethod_args( parse_p_args_string($returns), 'return' );
- $returns_indexes = "0" unless $returns_indexes;
-
- push @$regs_used, $returns_n_regs_used;
$e->emit( <<"END", __FILE__, __LINE__ + 1 );
{
/*BEGIN RETURN $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
+ Parrot_pcc_fill_returns_from_c_args(interp, _call_object, "$returns_signature",
+ $returns_varargs);
+ Parrot_pop_context(interp);
+ return;
/*END RETURN $returns */
}
END
$matched->replace( $match, $e );
}
- return $regs_used, $qty_returns;
}
sub parse_p_args_string {
@@ -305,16 +316,20 @@
sub process_pccmethod_args {
my ( $linear_args, $arg_type ) = @_;
- my $n_regs_used_a = [ 0, 0, 0, 0 ]; # INT, FLOAT, STRING, PMC counts
my $args = [ [], [], [], [] ]; # actual INT, FLOAT, STRING, PMC
- my $args_indexes_a = []; # arg index into interp context
- my $args_flags_a = []; # arg flags
- my $args_accessors = "";
- my $named_names = "";
+ my $signature = "";
+ my @vararg_list = ();
+ my $varargs = "";
+ my $declarations = "";
for my $arg (@$linear_args) {
my ( $named, $named_name ) = is_named($arg);
+ my $type = $arg->{type};
+ my $name = $arg->{name};
if ($named) {
+ my $tis = $reg_type_info->{+(REGNO_STR)}{s}; #reg_type_info string
+ my $dummy_name = "_param_name_str_". $named_name;
+ $dummy_name =~ s/"//g;
my $argn = {
type => +(REGNO_STR),
name => $named_name,
@@ -323,22 +338,25 @@
$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' );
+ $signature .= 'Sn';
+ $declarations .= "$tis $dummy_name = CONST_STRING_GEN(interp, $named_name);\n";
+ push @vararg_list, $dummy_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 );
+ push @{ $args->[ $type ] }, $arg;
+ $signature .= gen_arg_pcc_sig($arg);
+ if ( $arg_type eq 'arg' ) {
+ my $tis = $reg_type_info->{$type}{s}; #reg_type_info string
+ $declarations .= "$tis $name;\n";
+ push @vararg_list, "&$name"
+ }
+ elsif ( $arg_type eq 'return' ) {
+ push @vararg_list, "$name";
+ }
}
- 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 );
+ $varargs = join ", ", @vararg_list;
+ return ( $signature, $varargs, $declarations );
}
sub find_max_regs {
@@ -367,41 +385,32 @@
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
+ # parse pccmethod parameters, then unshift the 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')
+ attrs => parse_adverb_attributes(':invocant')
};
+ # The invocant is already passed in the C signature, why pass it again?
- my ( $params_n_regs_used, $params_indexes, $params_flags, $params_accessors, $named_names ) =
+ my ( $params_signature, $params_varargs, $params_declarations ) =
process_pccmethod_args( $linear_args, 'arg' );
- my ( $n_regs, $qty_returns ) = rewrite_RETURNs( $self, $pmc );
+ rewrite_RETURNs( $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 );
- const INTVAL _n_regs_used[] = { $n_regs_used };
- opcode_t _param_indexes[] = { $params_indexes };
- opcode_t *_return_indexes;
- opcode_t *_current_args;
- PMC * const _param_sig = pmc_new(interp, enum_class_FixedIntegerArray);
- PMC *_return_sig = PMCNULL;
+ PMC *_call_object = CONTEXT(interp)->current_sig;
+
+ const INTVAL _n_regs_used[] = { 0, 0, 0, 0 };
Parrot_Context *_caller_ctx = CONTEXT(interp);
PMC * const _ret_cont = new_ret_continuation_pmc(interp, NULL);
Parrot_Context *_ctx = Parrot_push_context(interp, _n_regs_used);
PMC *_ccont = PMCNULL;
-$set_params
- UNUSED(_return_indexes);
-
if (_caller_ctx) {
_ccont = _caller_ctx->current_cont;
}
@@ -414,68 +423,33 @@
_ctx->current_cont = _ret_cont;
PMC_cont(_ret_cont)->from_ctx = _ctx;
- _current_args = interp->current_args;
- interp->current_args = NULL;
-
+ { /* BEGIN PARMS SCOPE */
END
$e->emit(<<"END");
-$named_names
+$params_declarations
+END
+ if ($params_signature) {
+ $e->emit( <<"END", __FILE__, __LINE__ + 1 );
+ Parrot_pcc_fill_params_from_c_args(interp, _call_object, "$params_signature",
+ $params_varargs);
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, 1);
- 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 */
+ { /* BEGIN PMETHOD BODY */
END
- if ($qty_returns) {
- $e_post->emit( <<"END", __FILE__, __LINE__ + 1 );
-$method_returns
-
- if (! _caller_ctx) {
- /* there is no point calling Parrot_ex_throw_from_c_args here, because
- PDB_backtrace can't deal with a missing to_ctx either. */
- exit_fatal(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 */
- }
+ } /* END PMETHOD BODY */
+ } /* END PARAMS SCOPE */
no_return:
- PObj_live_CLEAR(_param_sig);
- PObj_live_CLEAR(_return_sig);
Parrot_pop_context(interp);
END
$self->return_type('void');
@@ -542,7 +516,7 @@
$vars .= $out_vars;
my $e = Parrot::Pmc2c::Emitter->new( $pmc->filename );
- $e->emit(qq|Parrot_PCCINVOKE($fixed_params, "$signature", $vars);\n|);
+ $e->emit(qq|Parrot_pcc_invoke_method_from_c_args($fixed_params, "$signature", $vars);\n|);
$matched->replace( $match, $e );
}
@@ -626,7 +600,7 @@
flatten => 'f',
slurpy => 's',
optional => 'o',
- positional => 'p',
+ opt_flag => 'p',
);
my @arg_names = ($name);
Modified: branches/pcc_rewiring/src/call/pcc.c
==============================================================================
--- branches/pcc_rewiring/src/call/pcc.c Mon Apr 20 22:15:54 2009 (r38239)
+++ branches/pcc_rewiring/src/call/pcc.c Mon Apr 20 23:56:39 2009 (r38240)
@@ -488,6 +488,14 @@
}
+ /* Check if we have an invocant, and add it to the front of the arguments */
+/* if (!PMC_IS_NULL(interp->current_object)) {
+ string_sig = Parrot_str_concat(interp, CONST_STRING(interp, "Pi"), string_sig, 0);
+ VTABLE_set_string_native(interp, call_object, string_sig);
+ VTABLE_unshift_pmc(interp, call_object, interp->current_object);
+ }
+*/
+
return call_object;
}
@@ -788,6 +796,13 @@
}
}
+ /* Check if we have an invocant, and add it to the front of the arguments */
+ if (!PMC_IS_NULL(obj)) {
+ string_sig = Parrot_str_concat(interp, CONST_STRING(interp, "Pi"), string_sig, 0);
+ VTABLE_set_string_native(interp, call_object, string_sig);
+ VTABLE_unshift_pmc(interp, call_object, obj);
+ }
+
/* Build a type_tuple for multiple dispatch */
type_tuple = Parrot_mmd_build_type_tuple_from_sig_obj(interp, call_object);
VTABLE_set_pmc(interp, call_object, type_tuple);
@@ -3806,168 +3821,23 @@
ARGIN(const char *signature), ...)
{
ASSERT_ARGS(Parrot_PCCINVOKE)
-#define PCC_ARG_MAX 1024
- /* variables from PCCINVOKE impl in PCCMETHOD.pm */
- /* args INSP, returns INSP */
- INTVAL n_regs_used[] = { 0, 0, 0, 0, 0, 0, 0, 0 };
-
- /* Each of these is 8K. Do we want 16K on the stack? */
- opcode_t arg_indexes[PCC_ARG_MAX];
- opcode_t result_indexes[PCC_ARG_MAX];
-
- PMC * const args_sig = pmc_new(interp, enum_class_FixedIntegerArray);
- PMC * const results_sig = pmc_new(interp, enum_class_FixedIntegerArray);
- PMC * const ret_cont = new_ret_continuation_pmc(interp, NULL);
-
- Parrot_Context *ctx; /* The newly created context */
- PMC *pccinvoke_meth;
-
- opcode_t *save_current_args;
- PMC *save_args_signature;
- PMC *save_current_object;
-
- /* temporary state vars for building PCC index and PCC signature arrays. */
-
- /* arg_indexes, result_indexes */
- opcode_t *indexes[2];
-
- /* args_sig, results_sig */
- PMC *sigs[2];
-
- int seen_arrow = 0;
-
- const char *x;
- const char *ret_x = NULL;
- int index = -1;
- int cur = 0;
-
- va_list list;
- va_start(list, signature);
-
- indexes[0] = arg_indexes;
- indexes[1] = result_indexes;
- sigs[0] = args_sig;
- sigs[1] = results_sig;
-
- /* account for passing invocant in-band */
- if (!pmc)
- Parrot_ex_throw_from_c_args(interp, NULL, 1,
- "NULL PMC passed into Parrot_PCCINVOKE");
-
- ctx = count_signature_elements(interp, signature, args_sig, results_sig, 1);
-
- /* second loop through signature to build all index and arg_flag
- * loop also assigns args(up to the ->) to registers */
-
- /* account for passing invocant in-band */
- indexes[0][0] = 0;
-
- VTABLE_set_integer_keyed_int(interp, sigs[0], 0, PARROT_ARG_PMC);
- CTX_REG_PMC(ctx, 0) = pmc;
-
- n_regs_used[REGNO_PMC]++;
- index = 0;
-
- for (x = signature; *x != '\0'; x++) {
- /* detect -> separator */
- if (*x == '-') {
-
- /* skip '>' */
- x++;
-
- /* allows us to jump directly to the result signature portion
- * during results assignment */
- ret_x = x;
-
- /* save off pointer to results */
- ret_x++;
-
- if (index >= 0)
- commit_last_arg(interp, index, cur, n_regs_used, seen_arrow,
- sigs, indexes, ctx, pmc, &list);
-
- /* reset parsing state so we can now handle results */
- seen_arrow = 1;
- index = -1;
-
- /* reset n_regs_used for reuse during result index allocation */
- n_regs_used[0] = 0;
- n_regs_used[1] = 0;
- n_regs_used[2] = 0;
- n_regs_used[3] = 0;
- }
- /* parse arg type */
- else if (isupper((unsigned char)*x)) {
- if (index >= 0)
- commit_last_arg(interp, index, cur, n_regs_used, seen_arrow,
- sigs, indexes, ctx, pmc, &list);
-
- index++;
-
- switch (*x) {
- case 'I': cur = PARROT_ARG_INTVAL; break;
- case 'N': cur = PARROT_ARG_FLOATVAL; break;
- case 'S': cur = PARROT_ARG_STRING; break;
- case 'P': cur = PARROT_ARG_PMC; break;
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_PCCINVOKE: invalid reg type %c!", *x);
- }
-
- }
- /* parse arg adverbs */
- else if (islower((unsigned char)*x)) {
- switch (*x) {
- case 'n': cur |= PARROT_ARG_NAME; break;
- case 'f': cur |= PARROT_ARG_FLATTEN; break;
- case 's': cur |= PARROT_ARG_SLURPY_ARRAY; break;
- case 'o': cur |= PARROT_ARG_OPTIONAL; break;
- case 'p': cur |= PARROT_ARG_OPT_FLAG; break;
- /* case 'l': cur |= PARROT_ARG_LOOKAHEAD; break; */
- default:
- Parrot_ex_throw_from_c_args(interp, NULL,
- EXCEPTION_INVALID_OPERATION,
- "Parrot_PCCINVOKE: invalid adverb type %c!", *x);
- }
- }
- }
-
- if (index >= 0)
- commit_last_arg(interp, index, cur, n_regs_used, seen_arrow, sigs,
- indexes, ctx, pmc, &list);
-
- /* code from PCCINVOKE impl in PCCMETHOD.pm */
- save_current_args = interp->current_args;
- save_args_signature = interp->args_signature;
- save_current_object = interp->current_object;
-
- interp->current_args = arg_indexes;
- interp->args_signature = args_sig;
- ctx->current_results = result_indexes;
- ctx->results_signature = results_sig;
-
- /* arg_accessors assigned in loop above */
-
- interp->current_object = pmc;
- interp->current_cont = NEED_CONTINUATION;
- ctx->current_cont = ret_cont;
- PMC_cont(ret_cont)->from_ctx = Parrot_context_ref(interp, ctx);
- pccinvoke_meth = VTABLE_find_method(interp, pmc, method_name);
+ PMC *sig_obj;
+ PMC *sub_obj;
+ va_list args;
+ va_start(args, signature);
+ sig_obj = Parrot_pcc_build_sig_object_from_varargs(interp, pmc, signature, args);
+ va_end(args);
- if (PMC_IS_NULL(pccinvoke_meth))
- Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_METHOD_NOT_FOUND,
- "Method '%Ss' not found", method_name);
- else
- VTABLE_invoke(interp, pccinvoke_meth, NULL);
+ /* Find the subroutine object as a named method on pmc */
+ sub_obj = VTABLE_find_method(interp, pmc, method_name);
+ if (PMC_IS_NULL(sub_obj))
+ Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_METHOD_NOT_FOUND,
+ "Method '%Ss' not found", method_name);
- set_context_sig_returns_varargs(interp, ctx, indexes, ret_x, list);
- PObj_live_CLEAR(args_sig);
- PObj_live_CLEAR(results_sig);
- interp->current_args = save_current_args;
- interp->args_signature = save_args_signature;
- interp->current_object = save_current_object;
- va_end(list);
+ /* Invoke the subroutine object with the given CallSignature object */
+ interp->current_object = pmc;
+ Parrot_pcc_invoke_from_sig_object(interp, sub_obj, sig_obj);
+ gc_unregister_pmc(interp, sig_obj);
}
/*
More information about the parrot-commits
mailing list