diff --git a/compilers/imcc/pbc.c b/compilers/imcc/pbc.c index 1500cebec5..554633b426 100644 --- a/compilers/imcc/pbc.c +++ b/compilers/imcc/pbc.c @@ -1124,9 +1124,8 @@ create_lexinfo(PARROT_INTERP, ARGMOD(IMC_Unit *unit), ARGIN(PMC *sub_pmc), "add lexical '%s' to sub name '%Ss'\n", n->name, sub->name); - Parrot_PCCINVOKE(interp, lex_info, - string_from_literal(interp, "declare_lex_preg"), - "SI->", lex_name, r->color); + VTABLE_set_integer_keyed_str(interp, lex_info, + lex_name, r->color); /* next possible name */ n = n->reg; diff --git a/config/gen/config_pm/config_lib_pasm.in b/config/gen/config_pm/config_lib_pasm.in index 6e3d49b3a1..0cbcf481a1 100644 --- a/config/gen/config_pm/config_lib_pasm.in +++ b/config/gen/config_pm/config_lib_pasm.in @@ -11,7 +11,7 @@ set I11, 1 # install flag no_arg: new P0, 'Hash' - new P1, 'Undef' + null P1 @PCONFIG@ diff --git a/include/parrot/call.h b/include/parrot/call.h index 2b929d9008..63f21597f9 100644 --- a/include/parrot/call.h +++ b/include/parrot/call.h @@ -35,6 +35,20 @@ typedef struct parrot_runloop_t { typedef parrot_runloop_t Parrot_runloop; +typedef enum { + CALLSIGNATURE_is_exception_FLAG = PObj_private0_FLAG, +} callsignature_flags_enum; + +#define CALLSIGNATURE_get_FLAGS(o) (PObj_get_FLAGS(o)) +#define CALLSIGNATURE_flag_TEST(flag, o) (CALLSIGNATURE_get_FLAGS(o) & CALLSIGNATURE_ ## flag ## _FLAG) +#define CALLSIGNATURE_flag_SET(flag, o) (CALLSIGNATURE_get_FLAGS(o) |= CALLSIGNATURE_ ## flag ## _FLAG) +#define CALLSIGNATURE_flag_CLEAR(flag, o) (CALLSIGNATURE_get_FLAGS(o) &= ~(UINTVAL)(CALLSIGNATURE_ ## flag ## _FLAG)) + +/* Mark if the CallSignature is for an exception handler */ +#define CALLSIGNATURE_is_exception_TEST(o) CALLSIGNATURE_flag_TEST(is_exception, (o)) +#define CALLSIGNATURE_is_exception_SET(o) CALLSIGNATURE_flag_SET(is_exception, (o)) +#define CALLSIGNATURE_is_exception_CLEAR(o) CALLSIGNATURE_flag_CLEAR(is_exception, (o)) + typedef enum call_state_mode { /* argument fetching/putting modes */ CALL_STATE_SIG = 0x100, /* runops, nci. In case we're interfacing with @@ -213,6 +227,17 @@ void parrot_pass_args(PARROT_INTERP, FUNC_MODIFIES(*src_indexes) FUNC_MODIFIES(*dest_indexes); +PARROT_EXPORT +PARROT_WARN_UNUSED_RESULT +PARROT_CANNOT_RETURN_NULL +PMC* Parrot_pcc_build_sig_object_from_op(PARROT_INTERP, + ARGIN_NULLOK(PMC *signature), + ARGIN(PMC * const raw_sig), + ARGIN(opcode_t * const raw_args)) + __attribute__nonnull__(1) + __attribute__nonnull__(3) + __attribute__nonnull__(4); + PARROT_EXPORT PARROT_WARN_UNUSED_RESULT PARROT_CANNOT_RETURN_NULL @@ -223,10 +248,63 @@ PMC* Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP, __attribute__nonnull__(1) __attribute__nonnull__(3); +PARROT_EXPORT +PARROT_WARN_UNUSED_RESULT +PARROT_CANNOT_RETURN_NULL +PMC* Parrot_pcc_build_sig_object_returns_from_op(PARROT_INTERP, + ARGIN_NULLOK(PMC *signature), + ARGIN(PMC *raw_sig), + ARGIN(opcode_t *raw_args)) + __attribute__nonnull__(1) + __attribute__nonnull__(3) + __attribute__nonnull__(4); + +PARROT_EXPORT +void Parrot_pcc_fill_params_from_c_args(PARROT_INTERP, + ARGMOD(PMC *call_object), + ARGIN(const char *signature), + ...) + __attribute__nonnull__(1) + __attribute__nonnull__(2) + __attribute__nonnull__(3) + FUNC_MODIFIES(*call_object); + +PARROT_EXPORT +void Parrot_pcc_fill_params_from_op(PARROT_INTERP, + ARGMOD(PMC *call_object), + ARGIN(PMC *raw_sig), + ARGIN(opcode_t *raw_params)) + __attribute__nonnull__(1) + __attribute__nonnull__(2) + __attribute__nonnull__(3) + __attribute__nonnull__(4) + FUNC_MODIFIES(*call_object); + +PARROT_EXPORT +void Parrot_pcc_fill_returns_from_c_args(PARROT_INTERP, + ARGMOD(PMC *call_object), + ARGIN(const char *signature), + ...) + __attribute__nonnull__(1) + __attribute__nonnull__(2) + __attribute__nonnull__(3) + FUNC_MODIFIES(*call_object); + +PARROT_EXPORT +void Parrot_pcc_fill_returns_from_op(PARROT_INTERP, + ARGMOD(PMC *call_object), + ARGIN(PMC *raw_sig), + ARGIN(opcode_t *raw_returns)) + __attribute__nonnull__(1) + __attribute__nonnull__(2) + __attribute__nonnull__(3) + __attribute__nonnull__(4) + FUNC_MODIFIES(*call_object); + PARROT_EXPORT void Parrot_pcc_invoke_from_sig_object(PARROT_INTERP, ARGIN(PMC *sub_obj), - ARGIN(PMC *sig_obj)) + ARGIN(PMC *call_object)) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__nonnull__(3); @@ -349,6 +427,7 @@ STRING* set_retval_s(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx)) && PARROT_ASSERT_ARG(sig) #define ASSERT_ARGS_parrot_pass_args __attribute__unused__ int _ASSERT_ARGS_CHECK = \ PARROT_ASSERT_ARG(interp) \ +<<<<<<< HEAD:include/parrot/call.h && PARROT_ASSERT_ARG(src_ctx) \ && PARROT_ASSERT_ARG(dest_ctx) #define ASSERT_ARGS_Parrot_pcc_build_sig_object_from_varargs \ @@ -360,6 +439,51 @@ STRING* set_retval_s(PARROT_INTERP, int sig_ret, ARGIN(PMC *ctx)) PARROT_ASSERT_ARG(interp) \ && PARROT_ASSERT_ARG(sub_obj) \ && PARROT_ASSERT_ARG(sig_obj) +======= + || PARROT_ASSERT_ARG(src_ctx) \ + || PARROT_ASSERT_ARG(dest_ctx) +#define ASSERT_ARGS_Parrot_pcc_build_sig_object_from_op \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(raw_sig) \ + || PARROT_ASSERT_ARG(raw_args) +#define ASSERT_ARGS_Parrot_pcc_build_sig_object_from_varargs \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(sig) +#define ASSERT_ARGS_Parrot_pcc_build_sig_object_returns_from_op \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(raw_sig) \ + || PARROT_ASSERT_ARG(raw_args) +#define ASSERT_ARGS_Parrot_pcc_fill_params_from_c_args \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(call_object) \ + || PARROT_ASSERT_ARG(signature) +#define ASSERT_ARGS_Parrot_pcc_fill_params_from_op \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(call_object) \ + || PARROT_ASSERT_ARG(raw_sig) \ + || PARROT_ASSERT_ARG(raw_params) +#define ASSERT_ARGS_Parrot_pcc_fill_returns_from_c_args \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(call_object) \ + || PARROT_ASSERT_ARG(signature) +#define ASSERT_ARGS_Parrot_pcc_fill_returns_from_op \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(call_object) \ + || PARROT_ASSERT_ARG(raw_sig) \ + || PARROT_ASSERT_ARG(raw_returns) +#define ASSERT_ARGS_Parrot_pcc_invoke_from_sig_object \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(sub_obj) \ + || PARROT_ASSERT_ARG(call_object) +>>>>>>> pcc_arg_unify_local:include/parrot/call.h #define ASSERT_ARGS_Parrot_pcc_invoke_method_from_c_args \ __attribute__unused__ int _ASSERT_ARGS_CHECK = \ PARROT_ASSERT_ARG(interp) \ @@ -688,8 +812,66 @@ void runops(PARROT_INTERP, size_t offs) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: src/call/ops.c */ +<<<<<<< HEAD:include/parrot/call.h #define ASSERT_SIG_PMC(sig) do {\ PARROT_ASSERT(!PMC_IS_NULL(sig)); \ +======= +/* HEADERIZER BEGIN: src/call/callsignature.c */ +/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ + +PARROT_EXPORT +PARROT_WARN_UNUSED_RESULT +PARROT_CANNOT_RETURN_NULL +opcode_t* Parrot_pcc_get_call_sig_raw_args(PARROT_INTERP, + ARGIN(PMC *call_sig)) + __attribute__nonnull__(1) + __attribute__nonnull__(2); + +PARROT_EXPORT +PARROT_WARN_UNUSED_RESULT +PARROT_CANNOT_RETURN_NULL +opcode_t* Parrot_pcc_get_call_sig_raw_returns(PARROT_INTERP, + ARGIN(PMC *call_sig)) + __attribute__nonnull__(1) + __attribute__nonnull__(2); + +PARROT_EXPORT +PARROT_CANNOT_RETURN_NULL +void Parrot_pcc_set_call_sig_raw_args(PARROT_INTERP, + ARGIN(PMC *call_sig), + ARGIN_NULLOK(opcode_t *raw_args)) + __attribute__nonnull__(1) + __attribute__nonnull__(2); + +PARROT_EXPORT +PARROT_CANNOT_RETURN_NULL +void Parrot_pcc_set_call_sig_raw_returns(PARROT_INTERP, + ARGIN(PMC *call_sig), + ARGIN_NULLOK(opcode_t *raw_returns)) + __attribute__nonnull__(1) + __attribute__nonnull__(2); + +#define ASSERT_ARGS_Parrot_pcc_get_call_sig_raw_args \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(call_sig) +#define ASSERT_ARGS_Parrot_pcc_get_call_sig_raw_returns \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(call_sig) +#define ASSERT_ARGS_Parrot_pcc_set_call_sig_raw_args \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(call_sig) +#define ASSERT_ARGS_Parrot_pcc_set_call_sig_raw_returns \ + __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(call_sig) +/* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ +/* HEADERIZER END: src/call/callsignature.c */ + +#define ASSERT_SIG_PMC(sig) \ +>>>>>>> pcc_arg_unify_local:include/parrot/call.h PARROT_ASSERT(PObj_is_PMC_TEST(sig)); \ PARROT_ASSERT((sig)->vtable->base_type == enum_class_FixedIntegerArray); \ } while (0) diff --git a/include/parrot/interpreter.h b/include/parrot/interpreter.h index 634d64da3c..c25dd5f69a 100644 --- a/include/parrot/interpreter.h +++ b/include/parrot/interpreter.h @@ -148,7 +148,6 @@ typedef struct warnings_t { * defined in imcc/imc.h */ struct _imc_info_t; - struct _Thread_data; /* in thread.h */ struct _Caches; /* caches .h */ diff --git a/lib/Parrot/Pmc2c/PCCMETHOD.pm b/lib/Parrot/Pmc2c/PCCMETHOD.pm index 5f1fca4f23..e3c092524e 100644 --- a/lib/Parrot/Pmc2c/PCCMETHOD.pm +++ b/lib/Parrot/Pmc2c/PCCMETHOD.pm @@ -79,10 +79,22 @@ use constant REGNO_PMC => 3; 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 @@ sub rtrim { =head3 C 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 @@ sub convert_type_string_to_reg_type { 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 @@ sub gen_arg_accessor { 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 @@ sub rewrite_RETURNs { 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 @@ sub rewrite_RETURNs { last unless $matched; } - $qty_returns++; $matched =~ /$signature_re/; my ( $match, $returns ) = ( $1, $2 ); @@ -215,7 +241,7 @@ sub rewrite_RETURNs { if ($returns eq 'void') { $e->emit( <<"END", __FILE__, __LINE__ + 1 ); /*BEGIN RETURN $returns */ - goto no_return; + return; /*END RETURN $returns */ END $matched->replace( $match, $e ); @@ -223,40 +249,23 @@ END } 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); + return; /*END RETURN $returns */ } END $matched->replace( $match, $e ); } - return $regs_used, $qty_returns; } sub parse_p_args_string { @@ -305,16 +314,20 @@ sub is_named { 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 +336,25 @@ sub process_pccmethod_args { $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,115 +383,53 @@ sub rewrite_pccmethod { 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 *_caller_ctx = interp->ctx; - PMC * const _ret_cont = new_ret_continuation_pmc(interp, NULL); - PMC *_ctx = Parrot_push_context(interp, _n_regs_used); - PMC *_ccont = PMCNULL; - -$set_params - UNUSED(_return_indexes); - - if (_caller_ctx) { - _ccont = Parrot_pcc_get_continuation(interp, _caller_ctx); - } - else { - /* 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); - } - - Parrot_pcc_set_continuation(interp, _ctx, _ret_cont); - PARROT_CONTINUATION(_ret_cont)->from_ctx = _ctx; + PMC *_caller_ct, *_ctx, *_ccont, *_call_object; - _current_args = interp->current_args; - interp->current_args = NULL; + _ctx = PARROT_CONTEXT(interp); + _ccont = Parrot_pcc_get_continuation(interp, _ctx); -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); + _caller_ctx = _ctx->caller_ctx; + _call_object = _ctx->current_sig; + _ctx->current_sig = NULL; - if (PObj_get_FLAGS(_ccont) & SUB_FLAG_TAILCALL) { - PObj_get_FLAGS(_ccont) &= ~SUB_FLAG_TAILCALL; - Parrot_pcc_dec_recursion_depth(interp, _ctx); - Parrot_pcc_set_caller_ctx(interp, _ctx, Parrot_pcc_get_caller_ctx(interp, _caller_ctx)); - interp->current_args = NULL; - } - /* BEGIN PARMS SCOPE */ - { + { /* BEGIN PARMS SCOPE */ END $e->emit(<<"END"); -$params_accessors +$params_declarations END - $e->emit( <<"END", __FILE__, __LINE__ + 1 ); - - /* BEGIN PMETHOD BODY */ - { + if ($params_signature) { + $e->emit( <<"END", __FILE__, __LINE__ + 1 ); + Parrot_pcc_fill_params_from_c_args(interp, _call_object, "$params_signature", + $params_varargs); END - - my $method_returns = $self->name . "_returns:"; - $e_post->emit( <<"END", __FILE__, __LINE__ + 1 ); - } - goto no_return; - /* END PMETHOD BODY */ - + $e->emit( <<"END", __FILE__, __LINE__ + 1 ); + { /* 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, - Parrot_pcc_get_results(interp, _caller_ctx), 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); + return; END $self->return_type('void'); $self->parameters(''); @@ -541,7 +495,7 @@ sub rewrite_pccinvoke { $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 ); } @@ -625,7 +579,7 @@ sub process_parameter { flatten => 'f', slurpy => 's', optional => 'o', - positional => 'p', + opt_flag => 'p', ); my @arg_names = ($name); diff --git a/src/call/pcc.c b/src/call/pcc.c index 50e6009b8e..12c499395b 100644 --- a/src/call/pcc.c +++ b/src/call/pcc.c @@ -118,6 +118,27 @@ static PMC * count_signature_elements(PARROT_INTERP, FUNC_MODIFIES(*args_sig) FUNC_MODIFIES(*results_sig); +static void dissect_aggregate_arg(PARROT_INTERP, + ARGMOD(PMC *call_object), + ARGIN(PMC *aggregate)) + __attribute__nonnull__(1) + __attribute__nonnull__(2) + __attribute__nonnull__(3) + FUNC_MODIFIES(*call_object); + +static void extract_named_arg_from_op(PARROT_INTERP, + ARGMOD(PMC *call_object), + ARGIN(STRING *name), + ARGIN(PMC * const raw_sig), + ARGIN(opcode_t * const raw_args), + INTVAL arg_index) + __attribute__nonnull__(1) + __attribute__nonnull__(2) + __attribute__nonnull__(3) + __attribute__nonnull__(4) + __attribute__nonnull__(5) + FUNC_MODIFIES(*call_object); + static int fetch_arg_op(PARROT_INTERP, ARGMOD(call_state *st)) __attribute__nonnull__(1) __attribute__nonnull__(2) @@ -151,6 +172,18 @@ static void null_val(int sig, ARGMOD(call_state *st)) __attribute__nonnull__(2) FUNC_MODIFIES(*st); +PARROT_CAN_RETURN_NULL +static void parse_signature_string(PARROT_INTERP, + ARGIN(const char *signature), + ARGMOD(PMC **arg_flags), + ARGMOD(PMC **return_flags)) + __attribute__nonnull__(1) + __attribute__nonnull__(2) + __attribute__nonnull__(3) + __attribute__nonnull__(4) + FUNC_MODIFIES(*arg_flags) + FUNC_MODIFIES(*return_flags); + PARROT_CAN_RETURN_NULL static const char * set_context_sig_params(PARROT_INTERP, ARGIN(const char *signature), @@ -272,9 +305,19 @@ static void too_many(PARROT_INTERP, && PARROT_ASSERT_ARG(st) #define ASSERT_ARGS_count_signature_elements __attribute__unused__ int _ASSERT_ARGS_CHECK = \ PARROT_ASSERT_ARG(interp) \ - && PARROT_ASSERT_ARG(signature) \ - && PARROT_ASSERT_ARG(args_sig) \ - && PARROT_ASSERT_ARG(results_sig) + || PARROT_ASSERT_ARG(signature) \ + || PARROT_ASSERT_ARG(args_sig) \ + || PARROT_ASSERT_ARG(results_sig) +#define ASSERT_ARGS_dissect_aggregate_arg __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(call_object) \ + || PARROT_ASSERT_ARG(aggregate) +#define ASSERT_ARGS_extract_named_arg_from_op __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(call_object) \ + || PARROT_ASSERT_ARG(name) \ + || PARROT_ASSERT_ARG(raw_sig) \ + || PARROT_ASSERT_ARG(raw_args) #define ASSERT_ARGS_fetch_arg_op __attribute__unused__ int _ASSERT_ARGS_CHECK = \ PARROT_ASSERT_ARG(interp) \ && PARROT_ASSERT_ARG(st) @@ -294,6 +337,11 @@ static void too_many(PARROT_INTERP, && PARROT_ASSERT_ARG(sti) #define ASSERT_ARGS_null_val __attribute__unused__ int _ASSERT_ARGS_CHECK = \ PARROT_ASSERT_ARG(st) +#define ASSERT_ARGS_parse_signature_string __attribute__unused__ int _ASSERT_ARGS_CHECK = \ + PARROT_ASSERT_ARG(interp) \ + || PARROT_ASSERT_ARG(signature) \ + || PARROT_ASSERT_ARG(arg_flags) \ + || PARROT_ASSERT_ARG(return_flags) #define ASSERT_ARGS_set_context_sig_params __attribute__unused__ int _ASSERT_ARGS_CHECK = \ PARROT_ASSERT_ARG(interp) \ && PARROT_ASSERT_ARG(signature) \ @@ -342,6 +390,330 @@ static void too_many(PARROT_INTERP, /* +=item C + +Take a raw signature and argument list from a set_args opcode and +convert it to a CallSignature PMC. + +=cut + +*/ + +PARROT_EXPORT +PARROT_WARN_UNUSED_RESULT +PARROT_CANNOT_RETURN_NULL +PMC* +Parrot_pcc_build_sig_object_from_op(PARROT_INTERP, ARGIN_NULLOK(PMC *signature), + ARGIN(PMC * const raw_sig), ARGIN(opcode_t * const raw_args)) +{ + ASSERT_ARGS(Parrot_pcc_build_sig_object_from_op) + PMC *call_object; + INTVAL arg_index; + INTVAL arg_count = VTABLE_elements(interp, raw_sig); + Parrot_Context *ctx = CONTEXT(interp); + STRING *string_sig = Parrot_str_new(interp, "", 0); + + if (PMC_IS_NULL(signature)) { + call_object = pmc_new(interp, enum_class_CallSignature); + gc_register_pmc(interp, call_object); + } + else + call_object = signature; + + VTABLE_set_attr_str(interp, call_object, CONST_STRING(interp, "arg_flags"), raw_sig); + + for (arg_index = 0; arg_index < arg_count; arg_index++) { + INTVAL arg_flags = VTABLE_get_integer_keyed_int(interp, + raw_sig, arg_index); + + const INTVAL constant = PARROT_ARG_CONSTANT_ISSET(arg_flags); + const INTVAL raw_index = raw_args[arg_index + 2]; + + switch (PARROT_ARG_TYPE_MASK_MASK(arg_flags)) { + case PARROT_ARG_INTVAL: + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "I")); + if (constant) + VTABLE_push_integer(interp, call_object, raw_index); + else + VTABLE_push_integer(interp, call_object, CTX_REG_INT(ctx, raw_index)); + break; + case PARROT_ARG_FLOATVAL: + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "N")); + if (constant) + VTABLE_push_float(interp, call_object, + ctx->constants[raw_index]->u.number); + else + VTABLE_push_float(interp, call_object, CTX_REG_NUM(ctx, raw_index)); + break; + case PARROT_ARG_STRING: + { + STRING *string_value; + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "S")); + if (constant) + /* ensure that callees don't modify constant caller strings */ + string_value = Parrot_str_new_COW(interp, + ctx->constants[raw_index]->u.string); + else + string_value = CTX_REG_STR(ctx, raw_index); + + if (arg_flags & PARROT_ARG_NAME) { + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "n")); + extract_named_arg_from_op(interp, call_object, string_value, + raw_sig, raw_args, raw_index); + } + else + VTABLE_push_string(interp, call_object, string_value); + + break; + } + case PARROT_ARG_PMC: + { + PMC *pmc_value; + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "P")); + if (constant) + pmc_value = ctx->constants[raw_index]->u.key; + else + pmc_value = CTX_REG_PMC(ctx, raw_index); + + if (arg_flags & PARROT_ARG_FLATTEN) { + dissect_aggregate_arg(interp, call_object, pmc_value); + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "f")); + } + else + VTABLE_push_pmc(interp, call_object, CTX_REG_PMC(ctx, raw_index)); + + break; + } + default: + break; + } + + } + + VTABLE_set_string_native(interp, call_object, string_sig); + return call_object; +} + +/* + +=item C + +Pulls in the next argument from a set_args opcode, and sets it as the +value of a named argument in the CallSignature PMC. + +=cut + +*/ + +static void +extract_named_arg_from_op(PARROT_INTERP, ARGMOD(PMC *call_object), ARGIN(STRING *name), + ARGIN(PMC * const raw_sig), ARGIN(opcode_t * const raw_args), + INTVAL arg_index) +{ + ASSERT_ARGS(extract_named_arg_from_op) + Parrot_Context *ctx = CONTEXT(interp); + INTVAL arg_flags = VTABLE_get_integer_keyed_int(interp, + raw_sig, arg_index); + + const INTVAL constant = PARROT_ARG_CONSTANT_ISSET(arg_flags); + const INTVAL raw_index = raw_args[arg_index + 2]; + STRING *string_sig = VTABLE_get_string(interp, call_object); + + switch (PARROT_ARG_TYPE_MASK_MASK(arg_flags)) { + case PARROT_ARG_INTVAL: + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "I")); + if (constant) + VTABLE_set_integer_keyed_str(interp, call_object, name, raw_index); + else + VTABLE_set_integer_keyed_str(interp, call_object, name, + CTX_REG_INT(ctx, raw_index)); + break; + case PARROT_ARG_FLOATVAL: + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "N")); + if (constant) + VTABLE_set_number_keyed_str(interp, call_object, name, + ctx->constants[raw_index]->u.number); + else + VTABLE_set_number_keyed_str(interp, call_object, name, + CTX_REG_NUM(ctx, raw_index)); + break; + case PARROT_ARG_STRING: + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "S")); + if (constant) + /* ensure that callees don't modify constant caller strings */ + VTABLE_set_string_keyed_str(interp, call_object, name, + Parrot_str_new_COW(interp, + ctx->constants[raw_index]->u.string)); + else + VTABLE_set_string_keyed_str(interp, call_object, name, + CTX_REG_STR(ctx, raw_index)); + break; + case PARROT_ARG_PMC: + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "P")); + if (constant) + VTABLE_set_pmc_keyed_str(interp, call_object, name, + ctx->constants[raw_index]->u.key); + else + VTABLE_set_pmc_keyed_str(interp, call_object, name, + CTX_REG_PMC(ctx, raw_index)); + break; + default: + break; + } + + VTABLE_set_string_native(interp, call_object, string_sig); +} + +/* + +=item C + +Takes an aggregate PMC and splits it up into individual arguments, +adding each one to the CallSignature PMC. If the aggregate is an array, +its elements are added as positional arguments. If the aggregate is a +hash, its key/value pairs are added as named arguments. + +=cut + +*/ + +static void +dissect_aggregate_arg(PARROT_INTERP, ARGMOD(PMC *call_object), ARGIN(PMC *aggregate)) +{ + ASSERT_ARGS(dissect_aggregate_arg) + + if (VTABLE_does(interp, aggregate, CONST_STRING(interp, "array"))) { + INTVAL elements = VTABLE_elements(interp, aggregate); + INTVAL index; + for (index = 0; index < elements; index++) { + VTABLE_push_pmc(interp, call_object, + VTABLE_get_pmc_keyed_int(interp, aggregate, index)); + } + } + else if (VTABLE_does(interp, aggregate, CONST_STRING(interp, "hash"))) { + INTVAL elements = VTABLE_elements(interp, aggregate); + INTVAL index; + PMC *key = pmc_new(interp, enum_class_Key); + VTABLE_set_integer_native(interp, key, 0); + SETATTR_Key_next_key(interp, key, (PMC *)INITBucketIndex); + + /* Low-level hash iteration. */ + for (index = 0; index < elements; index++) { + if (!PMC_IS_NULL(key)) { + STRING *name = (STRING *)parrot_hash_get_idx(interp, + (Hash *)VTABLE_get_pointer(interp, aggregate), key); + PARROT_ASSERT(name); + VTABLE_set_pmc_keyed_str(interp, call_object, name, + VTABLE_get_pmc_keyed_str(interp, aggregate, name)); + } + } + } + else { + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "flattened parameters must be a hash or array"); + } + +} + +/* + +=item C + +Take a raw signature and argument list from a set_results opcode and +convert it to a CallSignature PMC. Uses an existing CallSignature PMC if +one was already created for set_args. Otherwise, creates a new one. + +=cut + +*/ + +PARROT_EXPORT +PARROT_WARN_UNUSED_RESULT +PARROT_CAN_RETURN_NULL +PMC* +Parrot_pcc_build_sig_object_returns_from_op(PARROT_INTERP, ARGIN_NULLOK(PMC *signature), + ARGIN(PMC *raw_sig), ARGIN(opcode_t *raw_args)) +{ + ASSERT_ARGS(Parrot_pcc_build_sig_object_returns_from_op) + PMC *call_object; + STRING *string_sig; + INTVAL arg_index; + INTVAL arg_count = VTABLE_elements(interp, raw_sig); + Parrot_Context *ctx = CONTEXT(interp); + PMC *returns = pmc_new(interp, enum_class_ResizablePMCArray); + + if (PMC_IS_NULL(signature)) { + call_object = pmc_new(interp, enum_class_CallSignature); + gc_register_pmc(interp, call_object); + } + else + call_object = signature; + + string_sig = VTABLE_get_string(interp, call_object); + + /* A hack to support 'get_results' as the way of fetching the + * exception object inside an exception handler. The first argument + * in the call object is the exception, stick it directly into the + * destination register. */ + if (CALLSIGNATURE_is_exception_TEST(call_object)) { + const INTVAL raw_index = raw_args[2]; + CTX_REG_PMC(ctx, raw_index) = + VTABLE_get_pmc_keyed_int(interp, call_object, 0); + return NULL; + } + + VTABLE_set_attr_str(interp, call_object, CONST_STRING(interp, "return_flags"), raw_sig); + VTABLE_set_attr_str(interp, call_object, CONST_STRING(interp, "returns"), returns); + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "->")); + + for (arg_index = 0; arg_index < arg_count; arg_index++) { + STRING * const signature = CONST_STRING(interp, "signature"); + INTVAL arg_flags = VTABLE_get_integer_keyed_int(interp, + raw_sig, arg_index); + const INTVAL raw_index = raw_args[arg_index + 2]; + + /* Returns store a pointer to the register, so they can pass + * the result back to the caller. */ + PMC * const val_pointer = pmc_new(interp, enum_class_CPointer); + VTABLE_push_pmc(interp, returns, val_pointer); + + switch (PARROT_ARG_TYPE_MASK_MASK(arg_flags)) { + case PARROT_ARG_INTVAL: + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "I")); + VTABLE_set_pointer(interp, val_pointer, (void *) &(CTX_REG_INT(ctx, raw_index))); + VTABLE_set_string_keyed_str(interp, val_pointer, signature, CONST_STRING(interp, "I")); + break; + case PARROT_ARG_FLOATVAL: + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "N")); + VTABLE_set_pointer(interp, val_pointer, (void *) &(CTX_REG_NUM(ctx, raw_index))); + VTABLE_set_string_keyed_str(interp, val_pointer, signature, CONST_STRING(interp, "N")); + break; + case PARROT_ARG_STRING: + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "S")); + VTABLE_set_pointer(interp, val_pointer, (void *) &(CTX_REG_STR(ctx, raw_index))); + VTABLE_set_string_keyed_str(interp, val_pointer, signature, CONST_STRING(interp, "S")); + break; + case PARROT_ARG_PMC: + string_sig = Parrot_str_append(interp, string_sig, CONST_STRING(interp, "P")); + VTABLE_set_pointer(interp, val_pointer, (void *) &(CTX_REG_PMC(ctx, raw_index))); + VTABLE_set_string_keyed_str(interp, val_pointer, signature, CONST_STRING(interp, "P")); + break; + default: + break; + } + + } + + VTABLE_set_string_native(interp, call_object, string_sig); + return call_object; +} + +/* + =item C @@ -363,6 +735,8 @@ Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP, ARGIN_NULLOK(PMC *obj), ASSERT_ARGS(Parrot_pcc_build_sig_object_from_varargs) PMC *type_tuple = PMCNULL; PMC *returns = PMCNULL; + PMC *arg_flags = PMCNULL; + PMC *return_flags = PMCNULL; PMC * const call_object = pmc_new(interp, enum_class_CallSignature); STRING *string_sig = Parrot_str_new_constant(interp, sig); const INTVAL sig_len = Parrot_str_byte_length(interp, string_sig); @@ -373,6 +747,9 @@ Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP, ARGIN_NULLOK(PMC *obj), return call_object; VTABLE_set_string_native(interp, call_object, string_sig); + parse_signature_string(interp, sig, &arg_flags, &return_flags); + VTABLE_set_attr_str(interp, call_object, CONST_STRING(interp, "arg_flags"), arg_flags); + VTABLE_set_attr_str(interp, call_object, CONST_STRING(interp, "return_flags"), return_flags); /* Process the varargs list */ for (i = 0; i < sig_len; ++i) { @@ -381,7 +758,7 @@ Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP, ARGIN_NULLOK(PMC *obj), /* Only create the returns array if it's needed */ if (in_return_sig && PMC_IS_NULL(returns)) { returns = pmc_new(interp, enum_class_ResizablePMCArray); - VTABLE_set_attr_str(interp, call_object, CONST_STRING(interp, "results"), returns); + VTABLE_set_attr_str(interp, call_object, CONST_STRING(interp, "returns"), returns); } if (in_return_sig) { @@ -411,7 +788,7 @@ Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP, ARGIN_NULLOK(PMC *obj), default: Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, - "Multiple Dispatch: invalid argument type %c!", type); + "Dispatch: invalid argument type %c!", type); } } else { @@ -427,7 +804,17 @@ Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP, ARGIN_NULLOK(PMC *obj), VTABLE_push_string(interp, call_object, va_arg(args, STRING *)); break; case 'P': - VTABLE_push_pmc(interp, call_object, va_arg(args, PMC *)); + { + INTVAL type_lookahead = Parrot_str_indexed(interp, string_sig, (i + 1)); + PMC * const pmc_arg = va_arg(args, PMC *); + VTABLE_push_pmc(interp, call_object, pmc_arg); + if (type_lookahead == 'i') { + if (i != 0) + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, + "Dispatch: only the first argument can be an invocant"); + i++; /* skip 'i' */ + } break; case '-': i++; /* skip '>' */ @@ -436,23 +823,736 @@ Parrot_pcc_build_sig_object_from_varargs(PARROT_INTERP, ARGIN_NULLOK(PMC *obj), default: Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, - "Multiple Dispatch: invalid argument type %c!", type); + "Dispatch: invalid argument type %c!", type); } } } - /* 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); + /* 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); + + return call_object; +} + +/* + +=item C + +Gets args for the current function call and puts them into position. +First it gets the positional non-slurpy parameters, then the positional +slurpy parameters, then the named parameters, and finally the named +slurpy parameters. + +=cut + +*/ + +PARROT_EXPORT +void +Parrot_pcc_fill_params_from_op(PARROT_INTERP, ARGMOD(PMC *call_object), + ARGIN(PMC *raw_sig), ARGIN(opcode_t *raw_params)) +{ + ASSERT_ARGS(Parrot_pcc_fill_params_from_op) + Parrot_Context *ctx = CONTEXT(interp); + INTVAL positional_elements = VTABLE_elements(interp, call_object); + INTVAL param_count = VTABLE_elements(interp, raw_sig); + STRING *param_name = NULL; + INTVAL param_index = 0; + INTVAL positional_index = 0; + INTVAL named_count = 0; + INTVAL slurpy_count = 0; + INTVAL optional_count = 0; + INTVAL err_check = 0; + INTVAL got_optional = -1; + + /* Check if we should be throwing errors. This is configured separately + * for parameters and return values. */ + if (PARROT_ERRORS_test(interp, PARROT_ERRORS_PARAM_COUNT_FLAG)) + err_check = 1; + + for (param_index = 0; param_index < param_count; param_index++) { + INTVAL param_flags = VTABLE_get_integer_keyed_int(interp, + raw_sig, param_index); + + const INTVAL raw_index = raw_params[param_index + 2]; + + /* opt_flag parameter */ + if (param_flags & PARROT_ARG_OPT_FLAG) { + if (optional_count <= 0) + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, + "optional flag with no optional parameter"); + if (got_optional < 0 || got_optional > 1) + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, + "unable to determine if optional argument was passed"); + + CTX_REG_INT(ctx, raw_index) = got_optional; + got_optional = -1; + continue; /* on to next parameter */ + } + /* Collected ("slurpy") parameter */ + else if (param_flags & PARROT_ARG_SLURPY_ARRAY) { + /* Collect named arguments into hash */ + if (param_flags & PARROT_ARG_NAME) { + PMC * const collect_named = pmc_new(interp, + Parrot_get_ctx_HLL_type(interp, enum_class_Hash)); + + CTX_REG_PMC(ctx, raw_index) = collect_named; + named_count += VTABLE_elements(interp, collect_named); + } + /* Collect positional arguments into array */ + else { + PMC *collect_positional; + if (named_count > 0) + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, + "named parameters must follow all positional parameters"); + collect_positional = pmc_new(interp, + Parrot_get_ctx_HLL_type(interp, enum_class_ResizablePMCArray)); + for (; positional_index < positional_elements; positional_index++) { + VTABLE_push_pmc(interp, collect_positional, + VTABLE_get_pmc_keyed_int(interp, call_object, positional_index)); + } + CTX_REG_PMC(ctx, raw_index) = collect_positional; + } + + continue; /* on to next parameter */ + } + /* Named non-collected */ + else if (param_flags & PARROT_ARG_NAME) { + /* Just store the name for now (this parameter is only the + * name). The next parameter is the actual value. */ + param_name = PARROT_ARG_CONSTANT_ISSET(param_flags) + ? ctx->constants[raw_index]->u.string + : CTX_REG_STR(ctx, raw_index); + + continue; + } + else if (!STRING_IS_NULL(param_name)) { + /* The previous parameter was a parameter name. Now set the + * value of the named parameter.*/ + if (VTABLE_exists_keyed_str(interp, call_object, param_name)) { + named_count++; + + switch (PARROT_ARG_TYPE_MASK_MASK(param_flags)) { + case PARROT_ARG_INTVAL: + CTX_REG_INT(ctx, raw_index) = + VTABLE_get_integer_keyed_str(interp, call_object, param_name); + break; + case PARROT_ARG_FLOATVAL: + CTX_REG_NUM(ctx, raw_index) = + VTABLE_get_number_keyed_str(interp, call_object, param_name); + break; + case PARROT_ARG_STRING: + CTX_REG_STR(ctx, raw_index) = + VTABLE_get_string_keyed_str(interp, call_object, param_name); + break; + case PARROT_ARG_PMC: + CTX_REG_PMC(ctx, raw_index) = + VTABLE_get_pmc_keyed_str(interp, call_object, param_name); + break; + default: + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, "invalid parameter type"); + break; + } + param_name = NULL; + continue; /* on to next parameter */ + } + + /* If the named parameter doesn't have a corresponding named + * argument, fall through to positional argument handling. */ + param_name = NULL; + } + + /* Positional non-collected */ + if (named_count > 0) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "named parameters must follow all positional parameters"); + if (slurpy_count > 0) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "slurpy parameters must follow ordinary positional parameters"); + + /* No more positional arguments available to assign */ + if (positional_index >= positional_elements) { + if (!(param_flags & PARROT_ARG_OPTIONAL)) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "too few positional arguments: %d passed, %d (or more) expected", + positional_elements, param_index + 1); + + got_optional = 0; + optional_count++; + switch (PARROT_ARG_TYPE_MASK_MASK(param_flags)) { + case PARROT_ARG_INTVAL: + CTX_REG_INT(ctx, raw_index) = 0; + break; + case PARROT_ARG_FLOATVAL: + CTX_REG_NUM(ctx, raw_index) = 0.0; + break; + case PARROT_ARG_STRING: + CTX_REG_STR(ctx, raw_index) = NULL; + break; + case PARROT_ARG_PMC: + CTX_REG_PMC(ctx, raw_index) = PMCNULL; + break; + default: + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, "invalid parameter type"); + break; + } + + continue; /* on to next parameter */ + } + + /* Otherwise, we have a positional argument to assign to the + * positional parameter, so go ahead and assign it. */ + if (param_flags & PARROT_ARG_OPTIONAL) { + got_optional = 1; + optional_count++; + } + + switch (PARROT_ARG_TYPE_MASK_MASK(param_flags)) { + case PARROT_ARG_INTVAL: + CTX_REG_INT(ctx, raw_index) = + VTABLE_get_integer_keyed_int(interp, call_object, positional_index); + positional_index++; + break; + case PARROT_ARG_FLOATVAL: + CTX_REG_NUM(ctx, raw_index) = + VTABLE_get_number_keyed_int(interp, call_object, positional_index); + positional_index++; + break; + case PARROT_ARG_STRING: + CTX_REG_STR(ctx, raw_index) = + VTABLE_get_string_keyed_int(interp, call_object, positional_index); + positional_index++; + break; + case PARROT_ARG_PMC: + CTX_REG_PMC(ctx, raw_index) = + VTABLE_get_pmc_keyed_int(interp, call_object, positional_index); + positional_index++; + break; + default: + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, "invalid parameter type"); + break; + } + } + + if (err_check && (positional_elements > positional_index)) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "too many positional arguments: %d passed, %d expected", + positional_elements, param_count); + +} + +/* + +=item C + +Gets args for the current function call and puts them into position. +First it gets the positional non-slurpy parameters, then the positional +slurpy parameters, then the named parameters, and finally the named +slurpy parameters. + +The signature is a string in the format used for +C, but with no return arguments. The +parameters are passed in as a list of references to the destination +variables. + +=cut + +*/ + +PARROT_EXPORT +void +Parrot_pcc_fill_params_from_c_args(PARROT_INTERP, ARGMOD(PMC *call_object), + ARGIN(const char *signature), ...) +{ + ASSERT_ARGS(Parrot_pcc_fill_params_from_c_args) + va_list args; + Parrot_Context *ctx = CONTEXT(interp); + INTVAL positional_elements = VTABLE_elements(interp, call_object); + INTVAL param_count = 0; + STRING *param_name = NULL; + INTVAL param_index = 0; + INTVAL positional_index = 0; + INTVAL named_count = 0; + INTVAL slurpy_count = 0; + INTVAL optional_count = 0; + INTVAL err_check = 0; + INTVAL got_optional = -1; + PMC *raw_sig = PMCNULL; + PMC *invalid_sig = PMCNULL; + + parse_signature_string(interp, signature, &raw_sig, &invalid_sig); + if (!PMC_IS_NULL(invalid_sig)) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "returns should not be included in the parameter list"); + param_count = VTABLE_elements(interp, raw_sig); + + /* Check if we should be throwing errors. This is configured separately + * for parameters and return values. */ + if (PARROT_ERRORS_test(interp, PARROT_ERRORS_PARAM_COUNT_FLAG)) + err_check = 1; + + va_start(args, signature); + for (param_index = 0; param_index < param_count; param_index++) { + INTVAL param_flags = VTABLE_get_integer_keyed_int(interp, + raw_sig, param_index); + + /* opt_flag parameter */ + if (param_flags & PARROT_ARG_OPT_FLAG) { + if (optional_count <= 0) + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, + "optional flag with no optional parameter"); + if (got_optional < 0 || got_optional > 1) + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, + "unable to determine if optional argument was passed"); + + { + INTVAL * const int_pointer = va_arg(args, INTVAL*); + *int_pointer = got_optional; + } + got_optional = -1; + continue; /* on to next parameter */ + } + /* Collected ("slurpy") parameter */ + else if (param_flags & PARROT_ARG_SLURPY_ARRAY) { + /* Collect named arguments into hash */ + if (param_flags & PARROT_ARG_NAME) { + PMC * const collect_named = pmc_new(interp, + Parrot_get_ctx_HLL_type(interp, enum_class_Hash)); + + { + PMC ** const pmc_pointer = va_arg(args, PMC**); + *pmc_pointer = collect_named; + } + named_count += VTABLE_elements(interp, collect_named); + } + /* Collect positional arguments into array */ + else { + PMC *collect_positional; + if (named_count > 0) + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, + "named parameters must follow all positional parameters"); + collect_positional = pmc_new(interp, + Parrot_get_ctx_HLL_type(interp, enum_class_ResizablePMCArray)); + for (; positional_index < positional_elements; positional_index++) { + VTABLE_push_pmc(interp, collect_positional, + VTABLE_get_pmc_keyed_int(interp, call_object, positional_index)); + } + { + PMC ** const pmc_pointer = va_arg(args, PMC**); + *pmc_pointer = collect_positional; + } + } + + continue; /* on to next parameter */ + } + /* Named non-collected */ + else if (param_flags & PARROT_ARG_NAME) { + /* Just store the name for now (this parameter is only the + * name). The next parameter is the actual value. */ + STRING ** const string_pointer = va_arg(args, STRING**); + param_name = *string_pointer; + + continue; /* on to next parameter */ + } + else if (!STRING_IS_NULL(param_name)) { + /* The previous parameter was a parameter name. Now set the + * value of the named parameter.*/ + if (VTABLE_exists_keyed_str(interp, call_object, param_name)) { + named_count++; + + switch (PARROT_ARG_TYPE_MASK_MASK(param_flags)) { + case PARROT_ARG_INTVAL: + { + INTVAL * const int_pointer = va_arg(args, INTVAL*); + *int_pointer = + VTABLE_get_integer_keyed_str(interp, call_object, param_name); + } + break; + case PARROT_ARG_FLOATVAL: + { + FLOATVAL * const float_pointer = va_arg(args, FLOATVAL*); + *float_pointer = + VTABLE_get_number_keyed_str(interp, call_object, param_name); + } + break; + case PARROT_ARG_STRING: + { + STRING ** const string_pointer = va_arg(args, STRING**); + *string_pointer = + VTABLE_get_string_keyed_str(interp, call_object, param_name); + } + break; + case PARROT_ARG_PMC: + { + PMC ** const pmc_pointer = va_arg(args, PMC**); + *pmc_pointer = + VTABLE_get_pmc_keyed_str(interp, call_object, param_name); + } + break; + default: + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, "invalid parameter type"); + break; + } + param_name = NULL; + continue; /* on to next parameter */ + } + + /* If the named parameter doesn't have a corresponding named + * argument, fall through to positional argument handling. */ + param_name = NULL; + } + + /* Positional non-collected */ + if (named_count > 0) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "named parameters must follow all positional parameters"); + if (slurpy_count > 0) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "slurpy parameters must follow ordinary positional parameters"); + + /* No more positional arguments available to assign */ + if (positional_index >= positional_elements) { + if (!param_flags & PARROT_ARG_OPTIONAL) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "too few positional arguments: %d passed, %d (or more) expected", + positional_elements, param_index + 1); + + got_optional = 0; + optional_count++; + switch (PARROT_ARG_TYPE_MASK_MASK(param_flags)) { + case PARROT_ARG_INTVAL: + { + INTVAL * const int_pointer = va_arg(args, INTVAL*); + *int_pointer = 0; + } + break; + case PARROT_ARG_FLOATVAL: + { + FLOATVAL * const float_pointer = va_arg(args, FLOATVAL*); + *float_pointer = 0.0; + } + break; + case PARROT_ARG_STRING: + { + STRING ** const string_pointer = va_arg(args, STRING**); + *string_pointer = NULL; + } + break; + case PARROT_ARG_PMC: + { + PMC ** const pmc_pointer = va_arg(args, PMC**); + *pmc_pointer = PMCNULL; + } + break; + default: + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, "invalid parameter type"); + break; + } + + continue; /* on to next parameter */ + } + + /* Otherwise, we have a positional argument to assign to the + * positional parameter, so go ahead and assign it. */ + if (param_flags & PARROT_ARG_OPTIONAL) { + got_optional = 1; + optional_count++; + } + + switch (PARROT_ARG_TYPE_MASK_MASK(param_flags)) { + case PARROT_ARG_INTVAL: + { + INTVAL * const int_pointer = va_arg(args, INTVAL*); + *int_pointer = + VTABLE_get_integer_keyed_int(interp, call_object, positional_index); + } + positional_index++; + break; + case PARROT_ARG_FLOATVAL: + { + FLOATVAL * const float_pointer = va_arg(args, FLOATVAL*); + *float_pointer = + VTABLE_get_number_keyed_int(interp, call_object, positional_index); + } + positional_index++; + break; + case PARROT_ARG_STRING: + { + STRING ** const string_pointer = va_arg(args, STRING**); + *string_pointer = + VTABLE_get_string_keyed_int(interp, call_object, positional_index); + } + positional_index++; + break; + case PARROT_ARG_PMC: + { + PMC ** const pmc_pointer = va_arg(args, PMC**); + *pmc_pointer = + VTABLE_get_pmc_keyed_int(interp, call_object, positional_index); + } + positional_index++; + break; + default: + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, "invalid parameter type"); + break; + } + } + va_end(args); +} + +/* + +=item C + +Sets return values for the current function call. First it sets the +positional returns, then the named returns. + +=cut + +*/ + +PARROT_EXPORT +void +Parrot_pcc_fill_returns_from_op(PARROT_INTERP, ARGMOD(PMC *call_object), + ARGIN(PMC *raw_sig), ARGIN(opcode_t *raw_returns)) +{ + ASSERT_ARGS(Parrot_pcc_fill_returns_from_op) + INTVAL return_list_elements; + Parrot_Context *ctx = CONTEXT(interp); + PMC * const return_list = VTABLE_get_attr_str(interp, call_object, CONST_STRING(interp, "returns")); + PMC * const caller_return_flags = VTABLE_get_attr_str(interp, call_object, CONST_STRING(interp, "return_flags")); + INTVAL raw_return_count = VTABLE_elements(interp, raw_sig); + INTVAL return_index = 0; + INTVAL return_list_index = 0; + INTVAL err_check = 0; + + /* Check if we should be throwing errors. This is configured separately + * for parameters and return values. */ + if (PARROT_ERRORS_test(interp, PARROT_ERRORS_RESULT_COUNT_FLAG)) + err_check = 1; + + if (PMC_IS_NULL(return_list)) { + if (err_check) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "too many return values: %d passed, 0 expected", + raw_return_count, return_list_elements); + return; + } + else + return_list_elements = VTABLE_elements(interp, return_list); + + + if (raw_return_count > return_list_elements) { + if (err_check) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "too many return values: %d passed, %d expected", + raw_return_count, return_list_elements); + } + + for (return_index = 0; return_index < raw_return_count; return_index++) { + INTVAL return_flags = VTABLE_get_integer_keyed_int(interp, + raw_sig, return_index); + INTVAL result_flags; + + const INTVAL constant = PARROT_ARG_CONSTANT_ISSET(return_flags); + const INTVAL raw_index = raw_returns[return_index + 2]; + PMC *result_item = VTABLE_get_pmc_keyed_int(interp, return_list, return_list_index); + STRING *item_sig; + + /* Gracefully ignore extra returns when error checking is off. */ + if (PMC_IS_NULL(result_item)) + continue; /* Go on to next return arg. */ + + result_flags = VTABLE_get_integer_keyed_int(interp, caller_return_flags, return_list_index); + item_sig = VTABLE_get_string_keyed_str(interp, result_item, CONST_STRING(interp, '')); + + switch (PARROT_ARG_TYPE_MASK_MASK(return_flags)) { + case PARROT_ARG_INTVAL: + if (Parrot_str_equal(interp, item_sig, CONST_STRING(interp, "P"))) { + VTABLE_set_pmc(interp, result_item, + pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_Integer))); + } + if (constant) + VTABLE_set_integer_native(interp, result_item, raw_index); + else + VTABLE_set_integer_native(interp, result_item, CTX_REG_INT(ctx, raw_index)); + return_list_index++; + break; + case PARROT_ARG_FLOATVAL: + if (Parrot_str_equal(interp, item_sig, CONST_STRING(interp, "P"))) { + VTABLE_set_pmc(interp, result_item, + pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_Float))); + } + if (constant) + VTABLE_set_number_native(interp, result_item, + ctx->constants[raw_index]->u.number); + else + VTABLE_set_number_native(interp, result_item, CTX_REG_NUM(ctx, raw_index)); + return_list_index++; + break; + case PARROT_ARG_STRING: + if (Parrot_str_equal(interp, item_sig, CONST_STRING(interp, "P"))) { + VTABLE_set_pmc(interp, result_item, + pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_String))); + } + if (constant) + VTABLE_set_string_native(interp, result_item, Parrot_str_new_COW(interp, + ctx->constants[raw_index]->u.string)); + else + VTABLE_set_string_native(interp, result_item, CTX_REG_STR(ctx, raw_index)); + return_list_index++; + break; + case PARROT_ARG_PMC: + if (constant) + VTABLE_set_pmc(interp, result_item, ctx->constants[raw_index]->u.key); + else + VTABLE_set_pmc(interp, result_item, CTX_REG_PMC(ctx, raw_index)); + return_list_index++; + break; + default: + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, "invalid parameter type"); + break; + } + } +} + +/* + +=item C + +Sets return values for the current function call. First it sets the +positional returns, then the named returns. + +The signature is a string in the format used for +C, but with only return arguments. +The parameters are passed in as a list of INTVAL, FLOATVAL, STRING *, or +PMC * variables. + + +=cut + +*/ + +PARROT_EXPORT +void +Parrot_pcc_fill_returns_from_c_args(PARROT_INTERP, ARGMOD(PMC *call_object), + ARGIN(const char *signature), ...) +{ + ASSERT_ARGS(Parrot_pcc_fill_returns_from_c_args) + va_list args; + INTVAL return_list_elements; + Parrot_Context *ctx = CONTEXT(interp); + PMC * const return_list = VTABLE_get_attr_str(interp, call_object, CONST_STRING(interp, "returns")); + INTVAL raw_return_count = 0; + INTVAL return_index = 0; + INTVAL return_list_index = 0; + INTVAL err_check = 0; + + PMC *raw_sig = PMCNULL; + PMC *invalid_sig = PMCNULL; + + parse_signature_string(interp, signature, &raw_sig, &invalid_sig); + if (!PMC_IS_NULL(invalid_sig)) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "parameters should not be included in the return signature"); + raw_return_count = VTABLE_elements(interp, raw_sig); + + /* Check if we should be throwing errors. This is configured separately + * for parameters and return values. */ + if (PARROT_ERRORS_test(interp, PARROT_ERRORS_RESULT_COUNT_FLAG)) + err_check = 1; + + if (PMC_IS_NULL(return_list)) { + if (err_check) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "too many return values: %d passed, 0 expected", + raw_return_count, return_list_elements); + return; + } + else + return_list_elements = VTABLE_elements(interp, return_list); + + + if (raw_return_count > return_list_elements) { + if (err_check) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "too many return values: %d passed, %d expected", + raw_return_count, return_list_elements); } - /* 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); + va_start(args, signature); + for (return_index = 0; return_index < raw_return_count; return_index++) { + STRING *item_sig; + INTVAL return_flags = VTABLE_get_integer_keyed_int(interp, + raw_sig, return_index); - return call_object; + PMC *result_item = VTABLE_get_pmc_keyed_int(interp, return_list, return_list_index); + + /* Gracefully ignore extra returns when error checking is off. */ + if (PMC_IS_NULL(result_item)) + continue; /* Go on to next return arg. */ + + item_sig = VTABLE_get_string_keyed_str(interp, result_item, CONST_STRING(interp, '')); + + switch (PARROT_ARG_TYPE_MASK_MASK(return_flags)) { + case PARROT_ARG_INTVAL: + if (Parrot_str_equal(interp, item_sig, CONST_STRING(interp, "P"))) { + VTABLE_set_pmc(interp, result_item, pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_Integer))); + } + VTABLE_set_integer_native(interp, result_item, va_arg(args, INTVAL)); + return_list_index++; + break; + case PARROT_ARG_FLOATVAL: + if (Parrot_str_equal(interp, item_sig, CONST_STRING(interp, "P"))) { + VTABLE_set_pmc(interp, result_item, pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_Float))); + } + VTABLE_set_number_native(interp, result_item, va_arg(args, FLOATVAL)); + return_list_index++; + break; + case PARROT_ARG_STRING: + if (Parrot_str_equal(interp, item_sig, CONST_STRING(interp, "P"))) { + VTABLE_set_pmc(interp, result_item, pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_String))); + } + VTABLE_set_string_native(interp, result_item, + Parrot_str_new_COW(interp, va_arg(args, STRING *))); + return_list_index++; + break; + case PARROT_ARG_PMC: + VTABLE_set_pmc(interp, result_item, va_arg(args, PMC *)); + return_list_index++; + break; + default: + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, "invalid parameter type"); + break; + } + } + va_end(args); } @@ -2209,118 +3309,6 @@ commit_last_arg(PARROT_INTERP, int index, int cur, } -/* - -=item C - -Counts the number of each type of register in a signature object. Returns -the total number of parameter arguments, the total number of result -arguments, and the number of each type needed for register allocation. -Adds the necessary registers to a new context and returns the context. - -=cut - -*/ - -PARROT_CANNOT_RETURN_NULL -static PMC * -count_signature_elements(PARROT_INTERP, ARGIN(const char *signature), - ARGMOD(PMC *args_sig), ARGMOD(PMC *results_sig), int flag) -{ - ASSERT_ARGS(count_signature_elements) - const char *x; - - /*Count of number of each type of arg and result, INSP->INSP */ - int max_regs[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }; - - /* variables from PCCINVOKE impl in PCCMETHOD.pm */ - /* args INSP, returns INSP */ - INTVAL n_regs_used[] = { 0, 0, 0, 0, 0, 0, 0, 0 }; - - /* # of args, # of results */ - int arg_ret_cnt[2] = { 0, 0 }; - - unsigned int seen_arrow = 0; - - /* Increment these values if we are not calling from a CallSignature PMC */ - if (flag) { - arg_ret_cnt[seen_arrow]++; - max_regs[REGNO_PMC]++; - } - - /* Loop through the signature string to count the number of each - type of object required. We need to know so we can allocate - an appropriate number of registers for it. */ - for (x = signature; *x != '\0'; x++) { - switch (*x) { - case '-': - /* detect -> separator */ - seen_arrow = 1; - ++x; - if (*x != '>') - Parrot_ex_throw_from_c_args(interp, NULL, - EXCEPTION_INVALID_OPERATION, - "PCCINVOKE: invalid signature separator %c!", - *x); - break; - case 'I': - arg_ret_cnt[seen_arrow]++; - max_regs[seen_arrow * 4 + REGNO_INT]++; - break; - case 'N': - arg_ret_cnt[seen_arrow]++; - max_regs[seen_arrow * 4 + REGNO_NUM]++; - break; - case 'S': - arg_ret_cnt[seen_arrow]++; - max_regs[seen_arrow * 4 + REGNO_STR]++; - break; - case 'P': - arg_ret_cnt[seen_arrow]++; - { - /* Lookahead to see if PMC is marked as invocant */ - if (*(++x) == 'i') { - max_regs[REGNO_PMC]++; - } - else { - x--; /* Undo lookahead */ - max_regs[seen_arrow * 4 + REGNO_PMC]++; - } - } - break; - case 'f': - case 'n': - case 's': - case 'o': - case 'p': - /* case 'l': */ /* lookahead parameter */ - case 'i': - break; - default: - Parrot_ex_throw_from_c_args(interp, NULL, - EXCEPTION_INVALID_OPERATION, - "Parrot_PCCINVOKE: invalid reg type %c!", *x); - } - } - - /* calculate max reg types needed for both args and results */ - n_regs_used[0] = PARROT_MAX(max_regs[0], max_regs[4]); - n_regs_used[1] = PARROT_MAX(max_regs[1], max_regs[5]); - n_regs_used[2] = PARROT_MAX(max_regs[2], max_regs[6]); - n_regs_used[3] = PARROT_MAX(max_regs[3], max_regs[7]); - - /* initialize arg and return sig FIAs with collected info */ - if (arg_ret_cnt[0] > 0) - VTABLE_set_integer_native(interp, args_sig, arg_ret_cnt[0]); - - if (arg_ret_cnt[1] > 0) - VTABLE_set_integer_native(interp, results_sig, arg_ret_cnt[1]); - - return Parrot_push_context(interp, n_regs_used); -} - - /* =item C - -Sets the subroutine return arguments in the context C. Takes a C string -for the return signature C and a varargs list of return parameters -C. +=item C -To unify this function with C, C -needs to be changed to convert the va_list of input arguments into a signature -object, and the results list from that object needs to be passed to this -function instead of the va_list itself. +Parses a signature string and creates call and return signature integer +arrays. The two integer arrays should be passed in as references to a +PMC. =cut */ +PARROT_CAN_RETURN_NULL static void -set_context_sig_returns_varargs(PARROT_INTERP, ARGMOD(PMC *ctx), - ARGMOD(opcode_t **indexes), ARGIN(const char *ret_x), va_list returns) +parse_signature_string(PARROT_INTERP, ARGIN(const char *signature), + ARGMOD(PMC **arg_flags), ARGMOD(PMC **return_flags)) { - ASSERT_ARGS(set_context_sig_returns_varargs) - const char *x; - unsigned int index = 0; - unsigned int seen_arrow = 1; + ASSERT_ARGS(parse_signature_string) + PMC *current_array; + const char *x; + INTVAL flags = 0; + INTVAL set = 0; + + if (PMC_IS_NULL(*arg_flags)) + *arg_flags = pmc_new(interp, enum_class_ResizableIntegerArray); + current_array = *arg_flags; + + for (x = signature; *x != '\0'; x++) { + + /* detect -> separator */ + if (*x == '-') { + /* skip '>' */ + x++; + /* Switch to the return argument flags. */ + if (PMC_IS_NULL(*return_flags)) + *return_flags = pmc_new(interp, enum_class_ResizableIntegerArray); + current_array = *return_flags; + } + /* parse arg type */ + else if (isupper((unsigned char)*x)) { + /* Starting a new argument, so store the previous argument, + * if there was one. */ + if (set) { + VTABLE_push_integer(interp, current_array, flags); + set = 0; + } - /* result_accessors perform the arg accessor function, - * assigning the corresponding registers to the result variables */ - for (x = ret_x; x && *x; x++) { - if (isupper((unsigned char)*x)) { switch (*x) { - case 'I': - { - INTVAL * const tmpINTVAL = va_arg(returns, INTVAL *); - *tmpINTVAL = CTX_REG_INT(ctx, indexes[seen_arrow][index]); - } - break; - case 'N': - { - FLOATVAL * const tmpFLOATVAL = va_arg(returns, FLOATVAL *); - *tmpFLOATVAL = CTX_REG_NUM(ctx, indexes[seen_arrow][index]); - } - break; - case 'S': - { - STRING ** const tmpSTRING = va_arg(returns, STRING **); - *tmpSTRING = CTX_REG_STR(ctx, indexes[seen_arrow][index]); - } - break; - case 'P': - { - PMC ** const tmpPMC = va_arg(returns, PMC **); - *tmpPMC = CTX_REG_PMC(ctx, indexes[seen_arrow][index]); - } - break; + case 'I': flags = PARROT_ARG_INTVAL; set++; break; + case 'N': flags = PARROT_ARG_FLOATVAL; set++; break; + case 'S': flags = PARROT_ARG_STRING; set++; break; + case 'P': flags = PARROT_ARG_PMC; set++; break; + default: + Parrot_ex_throw_from_c_args(interp, NULL, + EXCEPTION_INVALID_OPERATION, + "invalid signature string element %c!", *x); + } + + } + /* parse arg adverbs */ + else if (islower((unsigned char)*x)) { + switch (*x) { + case 'c': flags |= PARROT_ARG_CONSTANT; break; + case 'f': flags |= PARROT_ARG_FLATTEN; break; + case 'i': flags |= PARROT_ARG_INVOCANT; break; + case 'l': flags |= PARROT_ARG_LOOKAHEAD; break; + case 'n': flags |= PARROT_ARG_NAME; break; + case 'o': flags |= PARROT_ARG_OPTIONAL; break; + case 'p': flags |= PARROT_ARG_OPT_FLAG; break; + case 's': flags |= PARROT_ARG_SLURPY_ARRAY; break; default: Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, - "Parrot_PCCINVOKE: invalid reg type %c!", *x); + "invalid signature string element %c!", *x); } } } - Parrot_pop_context(interp); + /* Store the final argument, if there was one. */ + if (set) + VTABLE_push_integer(interp, current_array, flags); } @@ -2756,166 +3761,23 @@ Parrot_PCCINVOKE(PARROT_INTERP, ARGIN(PMC* pmc), ARGMOD(STRING *method_name), 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); - - PMC *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; - Parrot_pcc_set_results(interp, ctx, result_indexes); - Parrot_pcc_set_results_signature(interp, ctx, results_sig); - - /* arg_accessors assigned in loop above */ - - interp->current_object = pmc; - interp->current_cont = NEED_CONTINUATION; - Parrot_pcc_set_continuation(interp, ctx, ret_cont); - PMC_cont(ret_cont)->from_ctx = 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); - 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); } /* @@ -2958,6 +3820,7 @@ Parrot_pcc_invoke_method_from_c_args(PARROT_INTERP, ARGIN(PMC* pmc), "Method '%Ss' not found", method_name); /* 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); @@ -2967,7 +3830,7 @@ Parrot_pcc_invoke_method_from_c_args(PARROT_INTERP, ARGIN(PMC* pmc), /* =item C +*call_object)> Follows the same conventions as C, but the subroutine object to invoke is passed as an argument rather than looked up by name, and the @@ -2980,75 +3843,19 @@ signature string and call arguments are passed in a CallSignature PMC. PARROT_EXPORT void Parrot_pcc_invoke_from_sig_object(PARROT_INTERP, ARGIN(PMC *sub_obj), - ARGIN(PMC *sig_obj)) + ARGIN(PMC *call_object)) { ASSERT_ARGS(Parrot_pcc_invoke_from_sig_object) -#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] = {0}; - opcode_t result_indexes[PCC_ARG_MAX] = {0}; - - /* create the signature string, and the various PMCs that are needed to - store all the parameters and parameter counts. */ - char * const signature = Parrot_str_to_cstring(interp, - VTABLE_get_string(interp, sig_obj)); - PMC * const args_sig = temporary_pmc_new(interp, - enum_class_FixedIntegerArray); - PMC * const results_sig = temporary_pmc_new(interp, - enum_class_FixedIntegerArray); - PMC * const ret_cont = new_ret_continuation_pmc(interp, NULL); - PMC * const result_list = VTABLE_get_attr_str(interp, sig_obj, CONST_STRING(interp, "returns")); - - PMC *ctx; - opcode_t *dest; - 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]; - - const char *ret_x = NULL; - - indexes[0] = arg_indexes; - indexes[1] = result_indexes; - sigs[0] = args_sig; - sigs[1] = results_sig; - - /* Count the number of objects of each type that need to be allocated by - the caller to perform this function call */ - ctx = count_signature_elements(interp, signature, args_sig, results_sig, 0); - - /* code from PCCINVOKE impl in PCCMETHOD.pm */ - /* Save the current values of the interpreter arguments so that additional - child sub calls don't kill our call stack. */ - save_current_args = interp->current_args; - save_args_signature = interp->args_signature; - save_current_object = interp->current_object; - - /* Set the function input parameters in the context structure, and return - * the offset in the signature where the return params start. */ - ret_x = set_context_sig_params(interp, signature, n_regs_used, - sigs, indexes, ctx, sig_obj); - - /* Set up the context object for the function invokation */ - if (strncmp(signature, "Pi", 2) == 0) - interp->current_object = VTABLE_get_pmc_keyed_int(interp, sig_obj, 0); - else - interp->current_object = PMCNULL; + opcode_t *dest; + INTVAL n_regs_used[] = { 0, 0, 0, 0, 0, 0, 0, 0 }; + Parrot_Context *ctx = Parrot_push_context(interp, n_regs_used); + PMC * const ret_cont = new_ret_continuation_pmc(interp, NULL); - interp->current_cont = NEED_CONTINUATION; - Parrot_pcc_set_continuation(interp, ctx, ret_cont); - PMC_cont(ret_cont)->from_ctx = ctx; + ctx->current_sig = call_object; + ctx->current_cont = ret_cont; + interp->current_cont = NEED_CONTINUATION; + PMC_cont(ret_cont)->from_ctx = Parrot_context_ref(interp, ctx); /* Invoke the function */ dest = VTABLE_invoke(interp, sub_obj, NULL); @@ -3066,18 +3873,9 @@ Parrot_pcc_invoke_from_sig_object(PARROT_INTERP, ARGIN(PMC *sub_obj), runops(interp, offset); interp->run_core = old_core; } - - /* Set the return values from the subroutine's context into the - caller's context */ - set_context_sig_returns(interp, ctx, indexes, ret_x, result_list); - - temporary_pmc_free(interp, args_sig); - temporary_pmc_free(interp, results_sig); - - interp->current_args = save_current_args; - interp->args_signature = save_args_signature; - interp->current_object = save_current_object; - Parrot_str_free_cstring(signature); + gc_unregister_pmc(interp, call_object); + ctx->current_sig = NULL; + Parrot_pop_context(interp); } diff --git a/src/debug.c b/src/debug.c index 9b3db6387a..d7dc1ed1b5 100644 --- a/src/debug.c +++ b/src/debug.c @@ -3540,6 +3540,7 @@ PDB_backtrace(PARROT_INTERP) STRING *str; PMC *old = PMCNULL; int rec_level = 0; + int limit_count = 0; /* information about the current sub */ PMC *sub = interpinfo_p(interp, CURRENT_SUB); @@ -3571,6 +3572,11 @@ PDB_backtrace(PARROT_INTERP) /* backtrace: follow the continuation chain */ while (1) { Parrot_Continuation_attributes *sub_cont; + + /* Limit the levels dumped, no segfault on infinite recursion */ + if (++limit_count > RECURSION_LIMIT) + break; + sub = Parrot_pcc_get_continuation(interp, ctx); if (PMC_IS_NULL(sub)) @@ -3581,13 +3587,18 @@ PDB_backtrace(PARROT_INTERP) if (!sub_cont) break; - str = Parrot_Context_infostr(interp, sub_cont->to_ctx); + + str = Parrot_Context_infostr(interp, ctx->caller_ctx); + if (!str) break; - /* recursion detection */ - if (!PMC_IS_NULL(old) && PMC_cont(old) && + + if (ctx == sub_cont->to_ctx) { + ++rec_level; + } + else if (!PMC_IS_NULL(old) && PMC_cont(old) && Parrot_pcc_get_pc(interp, PMC_cont(old)->to_ctx) == Parrot_pcc_get_pc(interp, PMC_cont(sub)->to_ctx) && Parrot_pcc_get_sub(interp, PMC_cont(old)->to_ctx) == @@ -3623,7 +3634,7 @@ PDB_backtrace(PARROT_INTERP) } /* get the next Continuation */ - ctx = PARROT_CONTINUATION(sub)->to_ctx; + ctx = Parrot_pcc_get_caller_ctx(interp, ctx); old = sub; if (!ctx) diff --git a/src/embed.c b/src/embed.c index db6cdc7f5c..214f02864c 100644 --- a/src/embed.c +++ b/src/embed.c @@ -824,7 +824,7 @@ Parrot_runcode(PARROT_INTERP, int argc, ARGIN(char **argv)) Parrot_pcc_set_sub(interp, CURRENT_CONTEXT(interp), NULL); Parrot_pcc_set_constants(interp, interp->ctx, interp->code->const_table->constants); - Parrot_runops_fromc_args(interp, main_sub, "vP", userargv); + Parrot_pcc_invoke_sub_from_c_args(interp, main_sub, "P->", userargv); } diff --git a/src/events.c b/src/events.c index ef516203c6..f8c0500c74 100644 --- a/src/events.c +++ b/src/events.c @@ -1471,8 +1471,8 @@ do_event(PARROT_INTERP, ARGIN(parrot_event* event), ARGIN_NULLOK(opcode_t *next) break; case EVENT_TYPE_TIMER: /* run ops, save registers */ - Parrot_runops_fromc_args_event(interp, - event->u.timer_event.sub, "v"); + Parrot_pcc_invoke_sub_from_c_args(interp, + event->u.timer_event.sub, "->"); break; case EVENT_TYPE_CALL_BACK: edebug((stderr, "starting user cb\n")); @@ -1481,9 +1481,9 @@ do_event(PARROT_INTERP, ARGIN(parrot_event* event), ARGIN_NULLOK(opcode_t *next) break; case EVENT_TYPE_IO: edebug((stderr, "starting io handler\n")); - Parrot_runops_fromc_args_event(interp, + Parrot_pcc_invoke_sub_from_c_args(interp, event->u.io_event.handler, - "vPP", + "PP->", event->u.io_event.pio, event->u.io_event.user_data); break; diff --git a/src/exceptions.c b/src/exceptions.c index 1ef1ab2291..f75e06d7a1 100644 --- a/src/exceptions.c +++ b/src/exceptions.c @@ -38,24 +38,18 @@ static PMC * build_exception_from_args(PARROT_INTERP, __attribute__nonnull__(3); PARROT_CAN_RETURN_NULL -static opcode_t * pass_exception_args(PARROT_INTERP, +static void pass_exception_args(PARROT_INTERP, ARGIN(const char *sig), - ARGIN(opcode_t *dest), - ARGIN(PMC * old_ctx), ...) __attribute__nonnull__(1) - __attribute__nonnull__(2) - __attribute__nonnull__(3) - __attribute__nonnull__(4); + __attribute__nonnull__(2); #define ASSERT_ARGS_build_exception_from_args __attribute__unused__ int _ASSERT_ARGS_CHECK = \ PARROT_ASSERT_ARG(interp) \ && PARROT_ASSERT_ARG(format) #define ASSERT_ARGS_pass_exception_args __attribute__unused__ int _ASSERT_ARGS_CHECK = \ PARROT_ASSERT_ARG(interp) \ - && PARROT_ASSERT_ARG(sig) \ - && PARROT_ASSERT_ARG(dest) \ - && PARROT_ASSERT_ARG(old_ctx) + || PARROT_ASSERT_ARG(sig) /* Don't modify between HEADERIZER BEGIN / HEADERIZER END. Your changes will be lost. */ /* HEADERIZER END: static */ @@ -240,20 +234,7 @@ Parrot_ex_throw_from_op(PARROT_INTERP, ARGIN(PMC *exception), ARGIN_NULLOK(void } address = VTABLE_invoke(interp, handler, dest); - - /* XXX This is an obvious hack. We need to identify here whether this is - an ExceptionHandler proper or a PIR-defined subclass. This conditional - monstrosity attempts to check whether this is an object of a PIR-defined - subclass. When we have garbage-collectable PMCs, we shouldn't need to do - this nonsense. See TT#154 for details */ - if (handler->vtable->base_type == enum_class_Object) { - /* Don't know what to do here to make sure the exception parameter gets - passed properly. */ - } - /* Set up the continuation context of the handler in the interpreter. */ - else if (PARROT_CONTINUATION(handler)->current_results) - address = pass_exception_args(interp, "P", address, - CURRENT_CONTEXT(interp), exception); + pass_exception_args(interp, "P", exception); if (PObj_get_FLAGS(handler) & SUB_FLAG_C_HANDLER) { /* it's a C exception handler */ @@ -267,8 +248,7 @@ Parrot_ex_throw_from_op(PARROT_INTERP, ARGIN(PMC *exception), ARGIN_NULLOK(void /* -=item C +=item C Passes arguments to the exception handler routine. These are retrieved with the .get_results() directive in PIR code. @@ -278,19 +258,20 @@ the .get_results() directive in PIR code. */ PARROT_CAN_RETURN_NULL -static opcode_t * -pass_exception_args(PARROT_INTERP, ARGIN(const char *sig), - ARGIN(opcode_t *dest), ARGIN(PMC * old_ctx), ...) +static void +pass_exception_args(PARROT_INTERP, ARGIN(const char *sig), ...) { ASSERT_ARGS(pass_exception_args) - va_list ap; - opcode_t *next; + va_list args; + PMC *sig_obj; + + va_start(args, sig); + sig_obj = Parrot_pcc_build_sig_object_from_varargs(interp, PMCNULL, sig, args); + va_end(args); - va_start(ap, old_ctx); - next = parrot_pass_args_fromc(interp, sig, dest, old_ctx, ap); - va_end(ap); + CALLSIGNATURE_is_exception_SET(sig_obj); - return next; + CONTEXT(interp)->current_sig = sig_obj; } /* @@ -380,6 +361,7 @@ Parrot_ex_throw_from_c(PARROT_INTERP, ARGIN(PMC *exception)) /* Don't split line. It will break CONST_STRING handling */ VTABLE_set_attr_str(interp, exception, CONST_STRING(interp, "thrower"), Parrot_pcc_get_continuation(interp, CURRENT_CONTEXT(interp))); + /* it's a C exception handler */ if (PObj_get_FLAGS(handler) & SUB_FLAG_C_HANDLER) { Parrot_runloop * const jump_point = @@ -389,11 +371,10 @@ Parrot_ex_throw_from_c(PARROT_INTERP, ARGIN(PMC *exception)) /* Run the handler. */ address = VTABLE_invoke(interp, handler, NULL); - if (PARROT_CONTINUATION(handler)->current_results) - address = pass_exception_args(interp, "P", address, - CURRENT_CONTEXT(interp), exception); + pass_exception_args(interp, "P", exception); PARROT_ASSERT(return_point->handler_start == NULL); return_point->handler_start = address; + longjmp(return_point->resume, 2); } diff --git a/src/extend.c b/src/extend.c index 1f18db2401..fa71b1c08e 100644 --- a/src/extend.c +++ b/src/extend.c @@ -1038,19 +1038,60 @@ Parrot_call_sub(PARROT_INTERP, Parrot_PMC sub_pmc, ARGIN(const char *signature), ...) { ASSERT_ARGS(Parrot_call_sub) - va_list ap; - void *result; - Parrot_Sub_attributes *sub; + va_list args; + PMC *sig_object; + void *result; + char return_sig = signature[0]; + const char *arg_sig = signature; + + arg_sig++; + va_start(args, signature); + sig_object = Parrot_pcc_build_sig_object_from_varargs(interp, PMCNULL, arg_sig, args); + va_end(args); - PARROT_CALLIN_START(interp); + /* Add the return argument onto the call signature object (a bit + * hackish, added for backward compatibility in deprecated API function, + * see TT #XXX). */ + switch (return_sig) { + case 'v': + { + Parrot_String full_sig = VTABLE_get_string(interp, sig_object); + Parrot_str_concat(interp, full_sig, + Parrot_str_new_constant(interp, "->"), 0); + break; + } + case 'V': + case 'P': + { + Parrot_String full_sig; + Parrot_PMC returns; + Parrot_PMC return_pointer; + Parrot_String return_name = Parrot_str_new_constant(interp, "returns"); + Parrot_String sig_name = Parrot_str_new_constant(interp, "signature"); + full_sig = VTABLE_get_string(interp, sig_object); + Parrot_str_concat(interp, full_sig, + Parrot_str_new_constant(interp, "->P"), 0); + + return_pointer = pmc_new(interp, enum_class_CPointer); + + returns = VTABLE_get_attr_str(interp, sig_object, return_name); + if (PMC_IS_NULL(returns)) { + returns = pmc_new(interp, enum_class_ResizablePMCArray); + VTABLE_set_attr_str(interp, sig_object, return_name, returns); + } + VTABLE_set_pointer(interp, return_pointer, &result); + VTABLE_set_string_keyed_str(interp, return_pointer, sig_name, + Parrot_str_new_constant(interp, "P")); + VTABLE_push_pmc(interp, returns, return_pointer); + break; + } + default: + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "Dispatch: invalid return type %c!", return_sig); + } - va_start(ap, signature); - PMC_get_sub(interp, sub_pmc, sub); - Parrot_pcc_set_constants(interp, CURRENT_CONTEXT(interp), sub->seg->const_table->constants); - result = Parrot_runops_fromc_arglist(interp, sub_pmc, signature, ap); - va_end(ap); + Parrot_pcc_invoke_from_sig_object(interp, sub_pmc, sig_object); - PARROT_CALLIN_END(interp); return result; } diff --git a/src/hash.c b/src/hash.c index c60b712361..fd51158794 100644 --- a/src/hash.c +++ b/src/hash.c @@ -1282,18 +1282,19 @@ parrot_hash_put(PARROT_INTERP, ARGMOD(Hash *hash), const UINTVAL hashval = (hash->hash_val)(interp, key, hash->seed); HashBucket *bucket = hash->bi[hashval & hash->mask]; - /* Very complex assert that we'll not put non-constant stuff into constant hash */ - PARROT_ASSERT( - PMC_IS_NULL(hash->container) - || !(PObj_constant_TEST(hash->container)) - || ( - ( - !(hash->key_type == Hash_key_type_STRING) - || PObj_constant_TEST((PObj *)key)) - && ( - !((hash->entry_type == enum_type_PMC) || (hash->entry_type == enum_type_STRING)) - || PObj_constant_TEST((PObj *)value))) - || !"Use non-constant key or value in constant hash"); + /* When the hash is constant, check that the key and value are also + * constant. */ + if (!PMC_IS_NULL(hash->container) + && PObj_constant_TEST(hash->container)) { + if (hash->key_type == Hash_key_type_STRING + && !PObj_constant_TEST((PObj *)key)) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "Used non-constant key in constant hash."); + if (((hash->entry_type == enum_type_PMC) || (hash->entry_type == enum_type_STRING)) + && !PObj_constant_TEST((PObj *)value)) + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION, + "Used non-constant value in constant hash."); + } while (bucket) { /* store hash_val or not */ diff --git a/src/interp/inter_cb.c b/src/interp/inter_cb.c index 33e14e726f..1ef7842258 100644 --- a/src/interp/inter_cb.c +++ b/src/interp/inter_cb.c @@ -299,9 +299,7 @@ Parrot_run_callback(PARROT_INTERP, PMC *sub; STRING *sig_str; char *p; - char ch; - char *sig_cstr; - char pasm_sig[4]; + char pasm_sig[5]; INTVAL i_param; PMC *p_param; void *param = NULL; /* avoid -Ox warning */ @@ -317,13 +315,12 @@ Parrot_run_callback(PARROT_INTERP, p = sig_cstr; ++p; /* Skip return type */ - pasm_sig[0] = 'v'; /* no return value supported yet */ - pasm_sig[1] = 'P'; + pasm_sig[0] = 'P'; if (*p == 'U') /* user_data Z in pdd16 */ ++p; /* p is now type of external data */ switch (*p) { case 'v': - pasm_sig[2] = 'v'; + pasm_sig[1] = 'v'; break; #if 0 case '2': @@ -342,7 +339,7 @@ Parrot_run_callback(PARROT_INTERP, case 'c': i_param = (INTVAL)(char)(long)external_data; case_I: - pasm_sig[2] = 'I'; + pasm_sig[1] = 'I'; param = (void*) i_param; break; #if 0 @@ -357,16 +354,16 @@ Parrot_run_callback(PARROT_INTERP, /* created a UnManagedStruct */ p_param = pmc_new(interp, enum_class_UnManagedStruct); VTABLE_set_pointer(interp, p_param, external_data); - pasm_sig[2] = 'P'; + pasm_sig[1] = 'P'; param = (void*) p_param; break; #if 0 case 'P': - pasm_sig[2] = 'P'; + pasm_sig[1] = 'P'; break; #endif case 't': - pasm_sig[2] = 'S'; + pasm_sig[1] = 'S'; param = Parrot_str_new(interp, external_data, 0); break; default: @@ -375,9 +372,10 @@ Parrot_run_callback(PARROT_INTERP, Parrot_ex_throw_from_c_args(interp, NULL, 1, "unhandled signature char '%c' in run_cb", ch); } - Parrot_str_free_cstring(sig_cstr); - pasm_sig[3] = '\0'; - Parrot_runops_fromc_args_event(interp, sub, pasm_sig, + pasm_sig[2] = '-'; + pasm_sig[3] = '>'; /* no return value supported yet */ + pasm_sig[4] = '\0'; + Parrot_pcc_invoke_sub_from_c_args(interp, sub, pasm_sig, user_data, param); } /* diff --git a/src/library.c b/src/library.c index dec66f56ec..ae449b07dc 100644 --- a/src/library.c +++ b/src/library.c @@ -162,6 +162,7 @@ parrot_init_library_paths(PARROT_INTERP) PMC *paths; STRING *entry; STRING *versionlib = NULL; + STRING *builddir = NULL; PMC * const iglobals = interp->iglobals; PMC * const config_hash = @@ -173,21 +174,31 @@ parrot_init_library_paths(PARROT_INTERP) VTABLE_set_pmc_keyed_int(interp, iglobals, IGLOBALS_LIB_PATHS, lib_paths); + if (VTABLE_elements(interp, config_hash)) { + STRING * const libkey = CONST_STRING(interp, "libdir"); + STRING * const verkey = CONST_STRING(interp, "versiondir"); + STRING * const builddirkey = CONST_STRING(interp, "build_dir"); + versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey); + entry = VTABLE_get_string_keyed_str(interp, config_hash, verkey); + versionlib = Parrot_str_append(interp, versionlib, entry); + + builddir = VTABLE_get_string_keyed_str(interp, config_hash, builddirkey); + } + /* each is an array of strings */ /* define include paths */ paths = pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_INCLUDE, paths); - entry = CONST_STRING(interp, "runtime/parrot/include/"); - VTABLE_push_string(interp, paths, entry); + if (!STRING_IS_NULL(builddir)) { + entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/"), 0); + VTABLE_push_string(interp, paths, entry); + entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/include/"), 0); + VTABLE_push_string(interp, paths, entry); + } entry = CONST_STRING(interp, "./"); VTABLE_push_string(interp, paths, entry); - if (VTABLE_elements(interp, config_hash)) { - STRING * const libkey = CONST_STRING(interp, "libdir"); - STRING * const verkey = CONST_STRING(interp, "versiondir"); - versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey); - entry = VTABLE_get_string_keyed_str(interp, config_hash, verkey); - versionlib = Parrot_str_append(interp, versionlib, entry); + if (!STRING_IS_NULL(versionlib)) { entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/include/"), 0); VTABLE_push_string(interp, paths, entry); } @@ -197,8 +208,10 @@ parrot_init_library_paths(PARROT_INTERP) paths = pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LIBRARY, paths); - entry = CONST_STRING(interp, "runtime/parrot/library/"); - VTABLE_push_string(interp, paths, entry); + if (!STRING_IS_NULL(builddir)) { + entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/library/"), 0); + VTABLE_push_string(interp, paths, entry); + } entry = CONST_STRING(interp, "./"); VTABLE_push_string(interp, paths, entry); if (!STRING_IS_NULL(versionlib)) { @@ -210,8 +223,10 @@ parrot_init_library_paths(PARROT_INTERP) paths = pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LANG, paths); - entry = CONST_STRING(interp, "runtime/parrot/languages/"); - VTABLE_push_string(interp, paths, entry); + if (!STRING_IS_NULL(builddir)) { + entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/languages/"), 0); + VTABLE_push_string(interp, paths, entry); + } entry = CONST_STRING(interp, "./"); VTABLE_push_string(interp, paths, entry); if (!STRING_IS_NULL(versionlib)) { @@ -223,8 +238,10 @@ parrot_init_library_paths(PARROT_INTERP) paths = pmc_new(interp, enum_class_ResizableStringArray); VTABLE_set_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_DYNEXT, paths); - entry = CONST_STRING(interp, "runtime/parrot/dynext/"); - VTABLE_push_string(interp, paths, entry); + if (!STRING_IS_NULL(builddir)) { + entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/dynext/"), 0); + VTABLE_push_string(interp, paths, entry); + } entry = CONST_STRING(interp, "dynext/"); VTABLE_push_string(interp, paths, entry); if (!STRING_IS_NULL(versionlib)) { diff --git a/src/multidispatch.c b/src/multidispatch.c index ce43582e49..821c4cf22a 100644 --- a/src/multidispatch.c +++ b/src/multidispatch.c @@ -654,25 +654,19 @@ PMC* Parrot_mmd_build_type_tuple_from_sig_obj(PARROT_INTERP, ARGIN(PMC *sig_obj)) { ASSERT_ARGS(Parrot_mmd_build_type_tuple_from_sig_obj) - PMC * const type_tuple = pmc_new(interp, enum_class_FixedIntegerArray); + PMC * const type_tuple = pmc_new(interp, enum_class_ResizableIntegerArray); STRING *string_sig = VTABLE_get_string(interp, sig_obj); - const INTVAL sig_len = Parrot_str_byte_length(interp, string_sig); INTVAL tuple_size = 0; INTVAL args_ended = 0; INTVAL i, seen_invocant = 0; + INTVAL sig_len; - /* First calculate the number of arguments participating in MMD */ - for (i = 0; i < sig_len; ++i) { - INTVAL type = Parrot_str_indexed(interp, string_sig, i); - if (type == '-') - break; - if (type == 'i') - continue; - - tuple_size++; + if (STRING_IS_NULL(string_sig)) { + Parrot_ex_throw_from_c_args(interp, NULL, 1, + "Call has no signature, unable to dispatch.\n"); } - VTABLE_set_integer_native(interp, type_tuple, tuple_size); + sig_len = Parrot_str_byte_length(interp, string_sig); for (i = 0; i < sig_len; ++i) { INTVAL type = Parrot_str_indexed(interp, string_sig, i + seen_invocant); diff --git a/src/ops/core.ops b/src/ops/core.ops index 6c6bc4dd68..ee374b5383 100644 --- a/src/ops/core.ops +++ b/src/ops/core.ops @@ -516,93 +516,75 @@ to the elements of the signature array. op set_args(inconst PMC) :flow { - opcode_t * const _this = CUR_OPCODE; + opcode_t * const raw_args = CUR_OPCODE; PMC * const signature = $1; INTVAL argc; - /* for now just point to the opcode */ - interp->current_args = _this; + CONTEXT(interp)->current_sig = + Parrot_pcc_build_sig_object_from_op(interp, + PMCNULL, signature, raw_args); + argc = VTABLE_elements(interp, signature); goto OFFSET(argc + 2); } op get_results(inconst PMC) :flow { - opcode_t * const _this = CUR_OPCODE; + opcode_t * const raw_returns = CUR_OPCODE; PMC * const signature = $1; INTVAL argc; - Parrot_pcc_set_results(interp, CURRENT_CONTEXT(interp), _this); + Parrot_pcc_set_current_sig(interp, CURRENT_CONTEXT(interp), + Parrot_pcc_build_sig_object_returns_from_op(interp, + Parrot_pcc_get_current_sig(interp, CURRENT_CONTEXT(interp)), + signature, raw_returns); + argc = VTABLE_elements(interp, signature); goto OFFSET(argc + 2); } op get_params(inconst PMC) :flow { - opcode_t * const _this = CUR_OPCODE; + opcode_t * const raw_params = CUR_OPCODE; PMC *caller_ctx, *ctx; - PMC * ccont; + PMC *ccont, *call_object; PMC * const signature = $1; INTVAL argc; - opcode_t *src_indexes, *dst_indexes; - interp->current_params = _this; - ctx = CURRENT_CONTEXT(interp); - ccont = Parrot_pcc_get_continuation(interp, ctx); + ctx = CURRENT_CONTEXT(interp); + ccont = Parrot_pcc_get_current_continuation(interp, ctx); - caller_ctx = Parrot_pcc_get_caller_ctx(interp, ctx); + caller_ctx = Parrot_pcc_get_caller_ctx(interp, ctx); + call_object = Parrot_pcc_get_current_sig(interp, caller_ctx); - src_indexes = interp->current_args; - dst_indexes = interp->current_params; - /* the args and params are now 'used.' */ - interp->current_args = NULL; - interp->current_params = NULL; + Parrot_pcc_fill_params_from_op(interp, call_object, signature, raw_params); - parrot_pass_args(interp, caller_ctx, ctx, src_indexes, dst_indexes, PARROT_PASS_PARAMS); /* TODO Factor out with Sub.invoke */ if (PObj_get_FLAGS(ccont) & SUB_FLAG_TAILCALL) { PObj_get_FLAGS(ccont) &= ~SUB_FLAG_TAILCALL; Parrot_pcc_dec_recursion_depth(interp, ctx); Parrot_pcc_set_caller_ctx(interp, ctx, Parrot_pcc_get_caller_ctx(interp, caller_ctx)); - interp->current_args = NULL; } argc = VTABLE_elements(interp, signature); goto OFFSET(argc + 2); } op set_returns(inconst PMC) :flow { - opcode_t * const _this = CUR_OPCODE; + opcode_t * const raw_returns = CUR_OPCODE; PMC *ctx, *caller_ctx; - PMC *ccont; + PMC *ccont, *call_object; PMC *signature = $1; INTVAL argc; - opcode_t *src_indexes, *dest_indexes; - - interp->current_returns = _this; - ctx = CURRENT_CONTEXT(interp); - caller_ctx = Parrot_pcc_get_caller_ctx(interp, ctx); - ccont = Parrot_pcc_get_continuation(interp, ctx); - - if (PARROT_CONTINUATION(ccont)->address) { - /* Call is from runops_fromc */ - caller_ctx = PMC_cont(ccont)->to_ctx; - if (PMC_IS_NULL(caller_ctx)) { - /* there is no point calling Parrot_ex_throw_..., because - PDB_backtrace can't deal with a missing to_ctx either. */ - exit_fatal(1, "No caller_ctx for continuation %p.", ccont); - } - src_indexes = interp->current_returns; - dest_indexes = Parrot_pcc_get_results(interp, caller_ctx); - interp->current_returns = NULL; - /* does this need to be here */ - interp->current_args = NULL; + ctx = CURRENT_CONTEXT(interp); + ccont = Parrot_pcc_get_current_continuation(interp, ctx); + + caller_ctx = Parrot_pcc_get_caller_ctx(interp, ctx); + call_object = Parrot_pcc_get_current_sig(interp, caller_ctx); + + Parrot_pcc_fill_returns_from_op(interp, call_object, signature, raw_returns); + + gc_unregister_pmc(interp, call_object); + Parrot_pcc_set_current_sig(interp, ctx, NULL); - parrot_pass_args(interp, ctx, caller_ctx, src_indexes, dest_indexes, PARROT_PASS_RESULTS); - } - else if (Parrot_pcc_get_results_signature(interp, caller_ctx)) { - /* We have a dynamic result signature, from pcc_invoke */ - parrot_pass_args(interp, ctx, caller_ctx, interp->current_returns, - Parrot_pcc_get_results(interp, caller_ctx), PARROT_PASS_RESULTS); - } argc = VTABLE_elements(interp, signature); goto OFFSET(argc + 2); } diff --git a/src/packfile.c b/src/packfile.c index a8c1091d0b..f2429e5a28 100644 --- a/src/packfile.c +++ b/src/packfile.c @@ -678,8 +678,8 @@ run_sub(PARROT_INTERP, ARGIN(PMC *sub_pmc)) Parrot_pcc_set_constants(interp, CURRENT_CONTEXT(interp), interp->code->const_table->constants); - retval = (PMC *)Parrot_runops_fromc_args(interp, sub_pmc, "P"); - interp->run_core = old_core; + Parrot_pcc_invoke_sub_from_c_args(interp, sub_pmc, "->P", &retval); + interp->run_core = old; return retval; } diff --git a/src/pmc/callsignature.pmc b/src/pmc/callsignature.pmc index 5f1a0b2215..046efdf183 100644 --- a/src/pmc/callsignature.pmc +++ b/src/pmc/callsignature.pmc @@ -28,9 +28,11 @@ information for a multiple dispatch call. PARROT_CAPTURE(obj)->hash = pmc_new((i), enum_class_Hash); pmclass CallSignature extends Capture auto_attrs provides array provides hash { - ATTR PMC *returns; /* Result PMCs, if they were passed with the call */ - ATTR PMC *type_tuple; /* Cached argument types for multiple dispatch */ - ATTR STRING *short_sig; /* Simple string signature args & returns */ + ATTR PMC *returns; /* Storage for return arguments */ + ATTR PMC *type_tuple; /* Cached argument types for multiple dispatch */ + ATTR STRING *short_sig; /* Simple string signature args & returns */ + ATTR PMC *arg_flags; /* Integer array of argument flags */ + ATTR PMC *return_flags; /* Integer array of return argument flags */ /* @@ -46,8 +48,10 @@ Initializes a newly created CallSignature object. Parrot_CallSignature_attributes * const sig_struct = (Parrot_CallSignature_attributes *) PMC_data(SELF); SUPER(); - sig_struct->type_tuple = PMCNULL; - sig_struct->returns = PMCNULL; + sig_struct->type_tuple = PMCNULL; + sig_struct->returns = PMCNULL; + sig_struct->arg_flags = PMCNULL; + sig_struct->return_flags = PMCNULL; } /* @@ -132,6 +136,16 @@ Set a PMC value for an attribute by string name. Stores the return signature, an array of PMCs. +=item arg_flags + +Stores a set of flags for the call signature arguments, an array of +integers. + +=item return_flags + +Stores a set of flags for the call signature return arguments, an array +of integers. + =back =cut @@ -139,8 +153,21 @@ Stores the return signature, an array of PMCs. */ VTABLE void set_attr_str(STRING *key, PMC *value) { - Parrot_CallSignature_attributes * const sig_struct = PARROT_CALLSIGNATURE(SELF); - sig_struct->returns = value; + + if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "returns"))) { + SET_ATTR_returns(interp, SELF, value); + } + else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "arg_flags"))) { + SET_ATTR_arg_flags(interp, SELF, value); + } + else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "return_flags"))) { + SET_ATTR_return_flags(interp, SELF, value); + } + else { + /* If unknown attribute name, throw an exception. */ + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ATTRIB_NOT_FOUND, + "No such attribute '%S'", key); + } } /* @@ -155,6 +182,16 @@ Get a PMC value for an attribute by string name. Retrieves the return signature, an array of PMCs. +=item arg_flags + +Retrieves the flags for the call signature arguments, an array of +integers. + +=item return_flags + +Retrieves the flags for the call signature return arguments, an array of +integers. + =back =cut @@ -162,8 +199,24 @@ Retrieves the return signature, an array of PMCs. */ VTABLE PMC *get_attr_str(STRING *key) { - Parrot_CallSignature_attributes * const sig_struct = PARROT_CALLSIGNATURE(SELF); - return sig_struct->returns; + PMC *value = PMCNULL; + + if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "returns"))) { + GET_ATTR_returns(interp, SELF, value); + } + else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "arg_flags"))) { + GET_ATTR_arg_flags(interp, SELF, value); + } + else if (Parrot_str_equal(INTERP, key, CONST_STRING(INTERP, "return_flags"))) { + GET_ATTR_return_flags(interp, SELF, value); + } + else { + /* If unknown attribute name, throw an exception. */ + Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_ATTRIB_NOT_FOUND, + "No such attribute '%S'", key); + } + + return value; } /* @@ -182,6 +235,8 @@ Mark any referenced strings and PMCs. Parrot_gc_mark_PMC_alive(interp, attrs->returns); Parrot_gc_mark_PMC_alive(interp, attrs->type_tuple); Parrot_gc_mark_STRING_alive(interp, attrs->short_sig); + Parrot_gc_mark_PMC_alive(interp, attrs->arg_flags); + Parrot_gc_mark_PMC_alive(interp, attrs->return_flags); } SUPER(); } diff --git a/src/pmc/capture.pmc b/src/pmc/capture.pmc index 6712f53a66..483382014f 100644 --- a/src/pmc/capture.pmc +++ b/src/pmc/capture.pmc @@ -417,6 +417,90 @@ Retrieves a value from the hash component of the Capture. /* +=item C + +=item C + +=item C + +=item C + +Sets a value in the hash component of the Capture. + +=cut + +*/ + + VTABLE void set_number_keyed_str(STRING *key, FLOATVAL value) { + CAPTURE_hash_CREATE(INTERP, SELF); + VTABLE_set_number_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, + key, value); + } + + VTABLE void set_integer_keyed_str(STRING *key, INTVAL value) { + CAPTURE_hash_CREATE(INTERP, SELF); + VTABLE_set_integer_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, + key, value); + } + + VTABLE void set_pmc_keyed_str(STRING *key, PMC *value) { + CAPTURE_hash_CREATE(INTERP, SELF); + VTABLE_set_pmc_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, + key, value); + } + + VTABLE void set_string_keyed_str(STRING *key, STRING *value) { + CAPTURE_hash_CREATE(INTERP, SELF); + VTABLE_set_string_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, + key, value); + } + +/* + +=item C + +=item C + +=item C + +=item C + +Retrieves a value in the hash component of the Capture. + +=cut + +*/ + + VTABLE FLOATVAL get_number_keyed_str(STRING *key) { + if (!(PARROT_CAPTURE(SELF)->hash)) + return 0.0; + return VTABLE_get_number_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, + key); + } + + VTABLE INTVAL get_integer_keyed_str(STRING *key) { + if (!(PARROT_CAPTURE(SELF)->hash)) + return 0; + return VTABLE_get_integer_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, + key); + } + + VTABLE PMC *get_pmc_keyed_str(STRING *key) { + if (!(PARROT_CAPTURE(SELF)->hash)) + return PMCNULL; + return VTABLE_get_pmc_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, + key); + } + + VTABLE STRING *get_string_keyed_str(STRING *key) { + if (!(PARROT_CAPTURE(SELF)->hash)) + return CONST_STRING(INTERP, ""); + return VTABLE_get_string_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, + key); + } + +/* + =item C Return true if element C of the hash component is defined. @@ -450,6 +534,39 @@ Delete the element corresponding to C in the hash component. /* +=item C + +Return true if element C of the hash component is defined. + +=item C + +Return true if element C of the hash component exists. + +=item C + +Delete the element corresponding to C in the hash component. + +=cut + +*/ + + VTABLE INTVAL defined_keyed_str(STRING *key) { + if (!PARROT_CAPTURE(SELF)->hash) return 0; + return VTABLE_defined_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, key); + } + + VTABLE INTVAL exists_keyed_str(STRING *key) { + if (!PARROT_CAPTURE(SELF)->hash) return 0; + return VTABLE_exists_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, key); + } + + VTABLE void delete_keyed_str(STRING *key) { + if (PARROT_CAPTURE(SELF)->hash) + VTABLE_delete_keyed_str(INTERP, PARROT_CAPTURE(SELF)->hash, key); + } + +/* + =item C Set this capture to hold the value of another. If set to PMCNULL, diff --git a/src/pmc/class.pmc b/src/pmc/class.pmc index a6425da191..57a31b824e 100644 --- a/src/pmc/class.pmc +++ b/src/pmc/class.pmc @@ -375,7 +375,8 @@ initialize_parents_pmc(PARROT_INTERP, PMC *object, PMC *all_parents, PMC *init) meth = Parrot_oo_find_vtable_override_for_class(interp, parent, name); if (!PMC_IS_NULL(meth)) - Parrot_run_meth_fromc_args(interp, meth, object, name, "vP", init); + Parrot_pcc_invoke_sub_from_c_args(interp, meth, + "PiP->", object, init); } } diff --git a/src/pmc/multisub.pmc b/src/pmc/multisub.pmc index 155ebf7825..a6d0c252fd 100644 --- a/src/pmc/multisub.pmc +++ b/src/pmc/multisub.pmc @@ -57,7 +57,9 @@ pmclass MultiSub extends ResizablePMCArray auto_attrs provides array { } VTABLE opcode_t *invoke(void *next) { - PMC * const func = Parrot_mmd_sort_manhattan(interp, SELF); + PMC * const sig_obj = CONTEXT(interp)->current_sig; + PMC * const func = Parrot_mmd_sort_manhattan_by_sig_pmc(interp, + SELF, sig_obj); if (PMC_IS_NULL(func)) Parrot_ex_throw_from_c_args(INTERP, NULL, 1, "No applicable methods.\n"); diff --git a/src/pmc/object.pmc b/src/pmc/object.pmc index 856042536a..1418198153 100644 --- a/src/pmc/object.pmc +++ b/src/pmc/object.pmc @@ -171,8 +171,12 @@ Returns the fully qualified name of the object's class. /* If there's a vtable override for 'name' run that instead. */ PMC * const method = Parrot_oo_find_vtable_override(interp, _class, name); - if (!PMC_IS_NULL(method)) - return (STRING *)Parrot_run_meth_fromc_args(interp, method, SELF, name, "S"); + if (!PMC_IS_NULL(method)) { + STRING *result; + Parrot_pcc_invoke_sub_from_c_args(interp, method, "Pi->S", + SELF, &result); + return result; + } else return VTABLE_get_string(interp, _class); } @@ -214,9 +218,12 @@ of the given name walking up the inheritance tree. PMC * const method = Parrot_oo_find_vtable_override(interp, VTABLE_get_class(interp, SELF), get_attr); - if (!PMC_IS_NULL(method)) - return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF, - get_attr, "PS", name); + if (!PMC_IS_NULL(method)) { + PMC *result; + Parrot_pcc_invoke_sub_from_c_args(interp, method, "PiS->P", + SELF, name, &result); + return result; + } /* Look up the index. */ index = get_attrib_index(interp, obj->_class, name); @@ -273,9 +280,8 @@ of the given name walking up the inheritance tree. PMC * const method = Parrot_oo_find_vtable_override(interp, VTABLE_get_class(interp, SELF), vtable_meth_name); if (!PMC_IS_NULL(method)) { - PMC *unused = (PMC *)Parrot_run_meth_fromc_args(interp, method, - SELF, vtable_meth_name, "vSP", name, value); - UNUSED(unused); + Parrot_pcc_invoke_sub_from_c_args(interp, method, "PiSP->", + SELF, name, value); return; } @@ -345,9 +351,12 @@ Queries this object's class to find the method with the given name. method = Parrot_oo_find_vtable_override_for_class(interp, cur_class, find_method); - if (!PMC_IS_NULL(method)) - return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF, - find_method, "PS", name); + if (!PMC_IS_NULL(method)) { + PMC *result; + Parrot_pcc_invoke_sub_from_c_args(interp, method, + "PiS->P", SELF, name, &result); + return result; + } /* If it's from this universe or the class doesn't inherit from * anything outside of it... */ @@ -391,9 +400,8 @@ Invoke the PIR-defined vtable override, or call the default get_integer. cur_class, meth_name); if (!PMC_IS_NULL(meth)) { INTVAL result; - Parrot_pcc_invoke_sub_from_c_args(interp, meth, "P->I", pmc, &result); + Parrot_pcc_invoke_sub_from_c_args(interp, meth, "Pi->I", pmc, &result); return result; -/* return (INTVAL)Parrot_run_meth_fromc_args_reti(interp, meth, pmc, meth_name, "I"); */ } /* method name is get_integer */ @@ -427,9 +435,12 @@ Get the class PMC representing the class that this object is an instance of. PMC * const method = Parrot_oo_find_vtable_override(interp, classobj, get_class); - if (!PMC_IS_NULL(method)) - return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF, - get_class, "P"); + if (!PMC_IS_NULL(method)) { + PMC *result; + Parrot_pcc_invoke_sub_from_c_args(interp, method, "Pi->P", + SELF, &result); + return result; + } return classobj; } @@ -451,9 +462,12 @@ Get the namespace PMC associated with the class that this object is an instance PMC * const method = Parrot_oo_find_vtable_override(interp, classobj, get_namespace); - if (!PMC_IS_NULL(method)) - return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF, - get_namespace, "P"); + if (!PMC_IS_NULL(method)) { + PMC *result; + Parrot_pcc_invoke_sub_from_c_args(interp, method, "Pi->P", + SELF, &result); + return result; + } else return VTABLE_inspect_str(interp, classobj, CONST_STRING(interp, "namespace")); @@ -537,9 +551,13 @@ Returns whether the object's class does the role with name C<*role_name>. PMC * const method = Parrot_oo_find_vtable_override(interp, classobj, meth_name); - if (!PMC_IS_NULL(method) - && Parrot_run_meth_fromc_args_reti(interp, method, SELF, meth_name, "IS", role_name)) - return 1; + if (!PMC_IS_NULL(method)) { + INTVAL result; + Parrot_pcc_invoke_sub_from_c_args(interp, method, + "PiS->I", SELF, role_name, &result); + if (result) + return 1; + } } /* Check the superclass's vtable interface, if any. */ if (SUPER(role_name)) @@ -641,15 +659,29 @@ Creates a clone of the object. VTABLE PMC * clone() { Parrot_Object_attributes * const obj = PARROT_OBJECT(pmc); - /* If we have a custom override, invoke it. - * If not, use the oo function. */ - STRING * const meth_name = CONST_STRING(interp, "clone"); - PMC * const meth = - Parrot_oo_find_vtable_override(interp, obj->_class, meth_name); - if (!PMC_IS_NULL(meth)) - return (PMC*)Parrot_run_meth_fromc_args(interp, meth, pmc, meth_name, "P"); - else - return Parrot_oo_clone_object(interp, SELF, obj->_class, NULL); + Parrot_Class_attributes * const _class = PARROT_CLASS(obj->_class); + STRING * const meth_name = CONST_STRING(interp, "clone"); + + /* See if we have a custom override of the method first. */ + const int num_classes = VTABLE_elements(interp, _class->all_parents); + int i; + for (i = 0; i < num_classes; i++) { + /* Get the class. */ + PMC * const cur_class = VTABLE_get_pmc_keyed_int(interp, _class->all_parents, i); + + /* Look for a method and run it if we find one. */ + PMC * const meth = + Parrot_oo_find_vtable_override_for_class(interp, cur_class, meth_name); + if (!PMC_IS_NULL(meth)) { + PMC *result; + Parrot_pcc_invoke_sub_from_c_args(interp, meth, "Pi->P", + pmc, &result); + return result; + } + } + + /* If we get here, no custom clone. Create a new object PMC. */ + return Parrot_oo_clone_object(interp, SELF, obj->_class, NULL); } /* @@ -793,7 +825,8 @@ Changes the PMC to a PMC of a new type classobj, meth_name); if (!PMC_IS_NULL(method)) - Parrot_run_meth_fromc_args(interp, method, SELF, meth_name, "vP", type); + Parrot_pcc_invoke_sub_from_c_args(interp, method, "PiP->", + SELF, type); else SUPER(type); } diff --git a/src/scheduler.c b/src/scheduler.c index fefb9c8dbe..b468f0d1fe 100644 --- a/src/scheduler.c +++ b/src/scheduler.c @@ -140,8 +140,8 @@ Parrot_cx_handle_tasks(PARROT_INTERP, ARGMOD(PMC *scheduler)) PMC * const handler = Parrot_cx_find_handler_for_task(interp, task); if (!PMC_IS_NULL(handler)) { PMC * const handler_sub = VTABLE_get_attr_str(interp, handler, CONST_STRING(interp, "code")); - Parrot_runops_fromc_args_event(interp, handler_sub, - "vPP", handler, task); + Parrot_pcc_invoke_sub_from_c_args(interp, handler_sub, + "PP->", handler, task); } } else { @@ -952,8 +952,8 @@ Parrot_cx_timer_invoke(PARROT_INTERP, ARGIN(PMC *timer)) Parrot_floatval_time()); #endif if (!PMC_IS_NULL(timer_struct->codeblock)) { - Parrot_runops_fromc_args_event(interp, - timer_struct->codeblock, "v"); + Parrot_pcc_invoke_sub_from_c_args(interp, + timer_struct->codeblock, "->"); } } diff --git a/src/thread.c b/src/thread.c index 24a2052483..57d6f5d023 100644 --- a/src/thread.c +++ b/src/thread.c @@ -532,7 +532,7 @@ thread_func(ARGIN_NULLOK(void *arg)) Parrot_ex_add_c_handler(interp, &jump_point); Parrot_unblock_GC_mark(interp); Parrot_unblock_GC_sweep(interp); - ret_val = Parrot_runops_fromc_args(interp, sub_pmc, "PF", sub_arg); + Parrot_pcc_invoke_sub_from_c_args(interp, sub_pmc, "P->P", sub_arg, &ret_val); } /* thread is finito */ diff --git a/src/utils.c b/src/utils.c index 502c21dbfb..0bffe04daf 100644 --- a/src/utils.c +++ b/src/utils.c @@ -906,6 +906,7 @@ static INTVAL COMPARE(PARROT_INTERP, ARGIN(void *a), ARGIN(void *b), ARGIN(PMC *cmp)) { ASSERT_ARGS(COMPARE) + INTVAL result; if (PMC_IS_NULL(cmp)) return VTABLE_cmp(interp, (PMC *)a, (PMC *)b); @@ -914,7 +915,8 @@ COMPARE(PARROT_INTERP, ARGIN(void *a), ARGIN(void *b), ARGIN(PMC *cmp)) return f(interp, a, b); } - return Parrot_runops_fromc_args_reti(interp, cmp, "IPP", a, b); + Parrot_pcc_invoke_sub_from_c_args(interp, cmp, "PP->I", a, b, &result); + return result; } /* diff --git a/t/op/annotate.t b/t/op/annotate.t index 70653b516f..b509613264 100644 --- a/t/op/annotate.t +++ b/t/op/annotate.t @@ -36,11 +36,13 @@ Test various use cases of the annotate directive. failed: .local pmc exception + pop_eh .get_results (exception) pop_eh $P0 = exception.'annotations'() isa_ok ($P0, 'Hash', 'annotations gives back hash') $I0 = elements $P0 +end is ($I0, 0, 'annotations hash empty when none in effect') $P0 = exception.'annotations'('line') $I0 = isnull $P0 @@ -59,6 +61,7 @@ Test various use cases of the annotate directive. failed: .local pmc exception + pop_eh .get_results (exception) pop_eh @@ -108,6 +111,7 @@ Test various use cases of the annotate directive. failed: .local pmc exception, bt, frame, ann + pop_eh .get_results (exception) pop_eh bt = exception.'backtrace'() diff --git a/t/op/calling.t b/t/op/calling.t index 9d3531c5bb..7ff7da464b 100644 --- a/t/op/calling.t +++ b/t/op/calling.t @@ -447,7 +447,7 @@ pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too few" ); print $P0 .end CODE -/too few arguments passed/ +/too few positional arguments/ OUTPUT pir_output_like( @@ -478,7 +478,7 @@ pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many - force ge print "nada" .end CODE -/too many arguments passed/ +/too many positional arguments/ OUTPUT pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many" ); @@ -496,7 +496,7 @@ pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many" ); print $P0 .end CODE -/too many arguments passed/ +/too many positional arguments/ OUTPUT pir_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, too many - catch exception" ); @@ -524,7 +524,7 @@ arg_handler: # print $S1 .end CODE -/^caught: too many arguments passed/ +/^caught: too many positional arguments/ OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "argc mismatch, optional" ); @@ -571,7 +571,7 @@ pir_error_output_like( <<'CODE', <<'OUTPUT', "argc mismatch, optional" ); .param int got_k :opt_flag .end CODE -/too many arguments passed/ +/too many positional arguments/ OUTPUT pasm_output_is( <<'CODE', <<'OUTPUT', "get_param later" ); @@ -1210,7 +1210,7 @@ pir_error_output_like( <<'CODE', <<'OUTPUT', "too many args via :flat" ); $P35 = _fn1(1, $P34 :flat) .end CODE -/too many arguments passed \(5\) - 4 params expected/ +/too many positional arguments: 5 passed, 4 expected/ OUTPUT pir_error_output_like( <<'CODE', <<'OUTPUT', "too few args via :flat" ); @@ -1242,7 +1242,7 @@ pir_error_output_like( <<'CODE', <<'OUTPUT', "too few args via :flat" ); $P35 = _fn1(1, $P34 :flat) .end CODE -/too few arguments passed \(3\) - 4 params expected/ +/too few positional arguments: 3 passed, 4 \(or more\) expected/ OUTPUT pir_output_is( <<'CODE', <<'OUTPUT', "tailcall to NCI" ); diff --git a/t/pmc/capture.t b/t/pmc/capture.t index e96e0e1fde..d8af57396b 100644 --- a/t/pmc/capture.t +++ b/t/pmc/capture.t @@ -226,6 +226,7 @@ a variety of keys and values. .return () test_get_integer_catch: + pop_eh .local pmc exception .local string message .get_results (exception) diff --git a/t/pmc/resizablestringarray.t b/t/pmc/resizablestringarray.t index d62799ac4f..4211f27bf2 100644 --- a/t/pmc/resizablestringarray.t +++ b/t/pmc/resizablestringarray.t @@ -1351,6 +1351,7 @@ err_2: .local pmc exception .local string message bad_type: + pop_eh .get_results (exception) message = exception still_ok: diff --git a/tools/build/nativecall.pl b/tools/build/nativecall.pl index f44c780f17..edabbfeccd 100644 --- a/tools/build/nativecall.pl +++ b/tools/build/nativecall.pl @@ -43,7 +43,7 @@ =head1 SEE ALSO as_proto => "void *", other_decl => "PMC * const final_destination = pmc_new(interp, enum_class_UnManagedStruct);", sig_char => "P", - ret_assign => "VTABLE_set_pointer(interp, final_destination, return_data); set_nci_P(interp, &st, final_destination);", + ret_assign => "VTABLE_set_pointer(interp, final_destination, return_data);\n Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"P\", final_destination);", }, i => { as_proto => "int", sig_char => "I" }, l => { as_proto => "long", sig_char => "I" }, @@ -53,7 +53,7 @@ =head1 SEE ALSO d => { as_proto => "double", sig_char => "N" }, t => { as_proto => "char *", other_decl => "STRING *final_destination;", - ret_assign => "final_destination = Parrot_str_new(interp, return_data, 0);\n set_nci_S(interp, &st, final_destination);", + ret_assign => "final_destination = Parrot_str_new(interp, return_data, 0);\n Parrot_pcc_fill_returns_from_c_args(interp, call_object, \"S\", final_destination);", sig_char => "S" }, v => { as_proto => "void", return_type => "void *", @@ -71,11 +71,11 @@ =head1 SEE ALSO B => { as_proto => "char **", as_return => "", sig_char => "S" }, # These should be replaced by modifiers in the future 2 => { as_proto => "short *", sig_char => "P", return_type => "short", - ret_assign => "set_nci_I(interp, &st, *return_data);" }, + ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' }, 3 => { as_proto => "int *", sig_char => "P", return_type => "int", - ret_assign => "set_nci_I(interp, &st, *return_data);" }, + ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' }, 4 => { as_proto => "long *", sig_char => "P", return_type => "long", - ret_assign => "set_nci_I(interp, &st, *return_data);" }, + ret_assign => 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "I", return_data);' }, L => { as_proto => "long *", as_return => "" }, T => { as_proto => "char **", as_return => "" }, V => { as_proto => "void **", as_return => "", sig_char => "P" }, @@ -87,7 +87,8 @@ =head1 SEE ALSO if (not exists $_->{return_type}) { $_->{return_type} = $_->{as_proto} } if (not exists $_->{return_type_decl}) { $_->{return_type_decl} = $_->{return_type} } if (not exists $_->{ret_assign} and exists $_->{sig_char}) { - $_->{ret_assign} = "set_nci_".$_->{sig_char}."(interp, &st, return_data);"; + $_->{ret_assign} = 'Parrot_pcc_fill_returns_from_c_args(interp, call_object, "' + . $_->{sig_char} . '", return_data);'; } if (not exists $_->{func_call_assign}) { $_->{func_call_assign} = "return_data = " @@ -120,6 +121,7 @@ =head1 SEE ALSO next; } + my @fill_params; my @extra_preamble; my @extra_postamble; my @temps; @@ -132,8 +134,8 @@ =head1 SEE ALSO die "Invalid argument signature char '$_' on line $. of $ARGV" unless exists $sig_table{$_}{sig_char}; push @arg, - make_arg( $_, $reg_num++, \$temp_cnt, \@temps, \@extra_preamble, - \@extra_postamble ); + make_arg( $_, $reg_num++, \$temp_cnt, \@temps, \@fill_params, + \@extra_preamble, \@extra_postamble ); $sig .= $sig_table{$_}{sig_char}; $_ eq 'J' && $reg_num--; } @@ -148,7 +150,7 @@ =head1 SEE ALSO $ret_sig->{as_return}, $ret_sig->{return_type_decl}, $ret_sig->{func_call_assign}, $ret_sig->{other_decl}, $ret_sig->{ret_assign}, \@temps, - \@extra_preamble, \@extra_postamble, + \@fill_params, \@extra_preamble, \@extra_postamble, \@put_pointer_nci_too, ); } @@ -159,7 +161,7 @@ =head1 SEE ALSO $ret_sig->{as_return}, $ret_sig->{return_type_decl}, $ret_sig->{func_call_assign}, $ret_sig->{other_decl}, $ret_sig->{ret_assign}, \@temps, - \@extra_preamble, \@extra_postamble, + \@fill_params, \@extra_preamble, \@extra_postamble, \@put_pointer, ); } @@ -201,7 +203,7 @@ sub print_head { */ /* nci.c - * Copyright (C) 2001-2007, Parrot Foundation. + * Copyright (C) 2001-2009, Parrot Foundation. * SVN Info * \$Id\$ * Overview: @@ -246,55 +248,78 @@ sub make_arg { # we have to fetch all to temps, so that the call code # can operate in sequence # - my ( $argtype, $reg_num, $temp_cnt_ref, $temps_ref, $extra_preamble_ref, $extra_postamble_ref ) + my ( $argtype, $reg_num, $temp_cnt_ref, $temps_ref, $fill_params_ref, $extra_preamble_ref, $extra_postamble_ref ) = @_; local $_ = $argtype; my $temp_num = ${$temp_cnt_ref}++; /p/ && do { - push @{$temps_ref}, "void *t_$temp_num;"; - push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_p($reg_num);"; - return "t_$temp_num"; + push @{$temps_ref}, "PMC *t_$temp_num;"; + push @{$fill_params_ref}, "&t_$temp_num"; + return "VTABLE_get_pointer(interp, t_$temp_num)"; }; /V/ && do { push @{$temps_ref}, "PMC *t_$temp_num;"; push @{$temps_ref}, "void *v_$temp_num;"; - push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_P($reg_num);"; + push @{$fill_params_ref}, "&t_$temp_num"; push @{$extra_preamble_ref}, "v_$temp_num = VTABLE_get_pointer(interp, t_$temp_num);"; push @{$extra_postamble_ref}, "VTABLE_set_pointer(interp, t_$temp_num, v_$temp_num);"; return "&v_$temp_num"; }; - /[ilIscfdNS]/ && do { + /[INS]/ && do { + my $ret_type = $sig_table{$_}{return_type}; + push @{$temps_ref}, "$ret_type t_$temp_num;"; + push @{$fill_params_ref}, "&t_$temp_num"; + return "t_$temp_num"; + }; + /[ilcs]/ && do { + my $ret_type = $sig_table{$_}{return_type}; + push @{$temps_ref}, "$ret_type t_$temp_num;"; + push @{$temps_ref}, "INTVAL ti_$temp_num;"; + push @{$fill_params_ref}, "&ti_$temp_num"; + push @{$extra_preamble_ref}, "t_$temp_num = ($ret_type)ti_$temp_num;"; + return "t_$temp_num"; + }; + /[fd]/ && do { my $ret_type = $sig_table{$_}{return_type}; push @{$temps_ref}, "$ret_type t_$temp_num;"; - push @{$extra_preamble_ref}, "t_$temp_num = ($ret_type)GET_NCI_$sig_table{$_}{sig_char}($reg_num);"; + push @{$temps_ref}, "FLOATVAL tf_$temp_num;"; + push @{$fill_params_ref}, "&tf_$temp_num"; + push @{$extra_preamble_ref}, "t_$temp_num = ($ret_type)tf_$temp_num;"; return "t_$temp_num"; }; /[234]/ && do { my $ret_type = $sig_table{$_}{return_type}; push @{$temps_ref}, "PMC *t_$temp_num;"; push @{$temps_ref}, "$ret_type i_$temp_num;"; - push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_P($reg_num);"; + push @{$fill_params_ref}, "&t_$temp_num"; push @{$extra_preamble_ref}, "i_$temp_num = ($ret_type) VTABLE_get_integer(interp, t_$temp_num);"; push @{$extra_postamble_ref}, "VTABLE_set_integer_native(interp, t_$temp_num, i_$temp_num);"; return "&i_$temp_num"; }; /t/ && do { - push @{$temps_ref}, "char *t_$temp_num;"; + push @{$temps_ref}, "char *t_$temp_num;"; + push @{$temps_ref}, "STRING *ts_$temp_num;"; + push @{$fill_params_ref}, "&ts_$temp_num"; push @{$extra_preamble_ref}, - "{STRING * s= GET_NCI_S($reg_num); t_$temp_num = s ? Parrot_str_to_cstring(interp, s) : (char *) NULL;}"; + "t_$temp_num = ts_$temp_num ? Parrot_str_to_cstring(interp, ts_$temp_num) : (char *) NULL;"; push @{$extra_postamble_ref}, "do { if (t_$temp_num) Parrot_str_free_cstring(t_$temp_num); } while (0);"; return "t_$temp_num"; }; /b/ && do { push @{$temps_ref}, "STRING *t_$temp_num;"; - push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_S($reg_num);"; - return "Buffer_bufstart(t_$temp_num)"; + push @{$fill_params_ref}, "&t_$temp_num"; + return "PObj_bufstart(t_$temp_num)"; }; /B/ && do { - push @{$temps_ref}, "char *s_$temp_num;\n char *t_$temp_num;\n char** v_$temp_num = &t_$temp_num;"; + push @{$temps_ref}, "char *s_$temp_num;"; + push @{$temps_ref}, "char *t_$temp_num;"; + push @{$temps_ref}, "void** v_$temp_num = (void **) &t_$temp_num;"; + push @{$temps_ref}, "STRING *ts_$temp_num;"; + push @{$fill_params_ref}, "&ts_$temp_num"; push @{$extra_preamble_ref}, - "{STRING * s= GET_NCI_S($reg_num); t_$temp_num = s ? Parrot_str_to_cstring(interp, s) : (char *) NULL; s_$temp_num = t_$temp_num;}"; + "t_$temp_num = ts_$temp_num ? Parrot_str_to_cstring(interp, ts_$temp_num) : (char *) NULL;"; + push @{$extra_preamble_ref}, "s_$temp_num = t_$temp_num;"; push @{$extra_postamble_ref}, "do { if (s_$temp_num) Parrot_str_free_cstring(s_$temp_num); } while (0);"; return "v_$temp_num"; }; @@ -302,19 +327,19 @@ sub make_arg { return "interp"; }; /[OP\@]/ && do { - push @{$temps_ref}, "PMC *t_$temp_num;"; - push @{$extra_preamble_ref}, "t_$temp_num = GET_NCI_P($reg_num);"; - return "t_$temp_num"; + push @{$temps_ref}, "PMC *t_$temp_num;"; + push @{$fill_params_ref}, "&t_$temp_num"; + return "PMC_IS_NULL(t_$temp_num) ? NULL : t_$temp_num"; }; return; } sub create_function { my ( - $sig, $return, $params, $args, - $ret_type, $ret_type_decl, $return_assign, $other_decl, - $final_assign, $temps_ref, $extra_preamble_ref, $extra_postamble_ref, - $put_pointer_ref, + $sig, $return, $params, $args, + $ret_type, $ret_type_decl, $return_assign, $other_decl, + $final_assign, $temps_ref, $fill_params_ref, $extra_preamble_ref, + $extra_postamble_ref, $put_pointer_ref, ) = @_; my $func = ''; @@ -322,10 +347,10 @@ sub create_function { $other_decl ||= ""; $other_decl .= join( "\n ", @{$temps_ref} ); - my $call_state = 'call_state st;'; - my $extra_preamble = join( "\n ", @{$extra_preamble_ref} ); - my $extra_postamble = join( "\n ", @{$extra_postamble_ref} ); - my $return_data = + my $call_object_decl = 'PMC *call_object;'; + my $extra_preamble = join( "\n ", @{$extra_preamble_ref} ); + my $extra_postamble = join( "\n ", @{$extra_postamble_ref} ); + my $return_data_decl = "$return_assign $final_assign" =~ /return_data/ ? qq{$ret_type_decl return_data;} : q{}; @@ -335,6 +360,8 @@ sub create_function { my $proto = join ', ', map { $sig_table{$_}{as_proto} } split( m//, $params ); my $call_params = join( ",", @$args ); + my $fill_params = join( ", ", @$fill_params_ref ); + $fill_params = ", " . $fill_params if($fill_params); $func = <<"HEADER"; static void @@ -343,10 +370,10 @@ sub create_function { typedef $ret_type (*func_t)($proto); func_t pointer; void *orig_func; - $call_state - $return_data + $call_object_decl + $return_data_decl $other_decl - Parrot_init_arg_nci(interp, &st, \"$sig\"); + Parrot_pcc_fill_params_from_c_args(interp, call_object, \"$sig\"$fill_params); $extra_preamble GETATTR_NCI_orig_func(interp, self, orig_func); @@ -360,17 +387,15 @@ sub create_function { else { # Things are more simple, when there are no params - # call state var not needed if there are no params and a void return - $call_state = '' if 'v' eq $return; $func = <<"HEADER"; static void pcf_${return}_(PARROT_INTERP, PMC *self) { $ret_type (*pointer)(void); void *orig_func; - $return_data + $return_data_decl $other_decl - $call_state + $call_object_decl $extra_preamble GETATTR_NCI_orig_func(interp, self, orig_func);