Skip to content

Commit

Permalink
ParseXS: always XSprePUSH when producing an output list
Browse files Browse the repository at this point in the history
The late XSprePUSH with a non-PUSHx() RETVAL was causing the
stack and accesses to ST(n) to be out of sync.

If generated RETVAL code does write directly to ST(n) (as much does),
doesn't generate a push and we're generating output list code,
adjust SP to match to keep things in sync.

Also test that the original example case that worked, continues to
work.

Fixes #19054
  • Loading branch information
tonycoz committed Sep 9, 2021
1 parent 034242a commit 8e7414c
Show file tree
Hide file tree
Showing 3 changed files with 57 additions and 9 deletions.
22 changes: 14 additions & 8 deletions dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
Expand Up @@ -690,10 +690,17 @@ EOF
do_push => undef,
} ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} };

my $prepush_done;
my $c = @{ $outlist_ref };
if ($c) {
my $ext = $c;
++$ext if $self->{gotRETVAL} || $wantRETVAL;
print "\tXSprePUSH;";
print "\tEXTEND(SP,$ext);\n";
}
# all OUTPUT done, so now push the return value on the stack
if ($self->{gotRETVAL} && $self->{RETVAL_code}) {
print "\t$self->{RETVAL_code}\n";
print "\t++SP;\n" if $c;
}
elsif ($self->{gotRETVAL} || $wantRETVAL) {
my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} );
Expand All @@ -708,8 +715,9 @@ EOF
);
if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv
# PUSHp corresponds to sv_setpvn. Treat sv_setpv directly
print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
$prepush_done = 1;
print "\tsv_setpv(TARG, $what);\n";
print "\tXSprePUSH;\n" unless $c;
print "\tPUSHTARG;\n";
}
else {
my $tsize = $trgt->{what_size};
Expand All @@ -718,8 +726,8 @@ EOF
qq("$tsize"),
{var => $var, type => $self->{ret_type}}
);
print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n";
$prepush_done = 1;
print "\tXSprePUSH;\n" unless $c;
print "\tPUSH$trgt->{type}($what$tsize);\n";
}
}
else {
Expand All @@ -731,14 +739,12 @@ EOF
do_setmagic => 0,
do_push => undef,
} );
print "\t++SP;\n" if $c;
}
}

$xsreturn = 1 if $self->{ret_type} ne "void";
my $num = $xsreturn;
my $c = @{ $outlist_ref };
print "\tXSprePUSH;" if $c and not $prepush_done;
print "\tEXTEND(SP,$c);\n" if $c;
$xsreturn += $c;
$self->generate_output( {
type => $self->{var_types}->{$_},
Expand Down
8 changes: 7 additions & 1 deletion dist/ExtUtils-ParseXS/t/002-more.t
Expand Up @@ -9,7 +9,7 @@ use ExtUtils::CBuilder;
use attributes;
use overload;

plan tests => 30;
plan tests => 32;

my ($source_file, $obj_file, $lib_file);

Expand Down Expand Up @@ -91,6 +91,12 @@ SKIP: {

is_deeply [XSMore::outlist()], [ord('a'), ord('b')], 'the OUTLIST keyword';

is_deeply [XSMore::outlist_bool("a", "b")], [ !0, "ab" ],
"OUTLIST with a bool RETVAL";

is_deeply [XSMore::outlist_int("c", "d")], [ 11, "cd" ],
"OUTLIST with an int RETVAL";

# eval so compile-time sees any prototype
is_deeply [ eval 'XSMore::outlist()' ], [ord('a'), ord('b')], 'OUTLIST prototypes';

Expand Down
36 changes: 36 additions & 0 deletions dist/ExtUtils-ParseXS/t/XSMore.xs
Expand Up @@ -38,6 +38,36 @@ outlist(int* a, int* b){
*b = 'b';
}

STATIC bool
outlist_bool(const char *a, const char *b, char **c)
{
dTHX;
STRLEN lena = strlen(a);
STRLEN lenb = strlen(b);
STRLEN lenc = lena + lenb;
Newx(*c, lenc+1, char);
strcpy(*c, a);
strcat(*c, b);
SAVEFREEPV(*c);

return TRUE;
}

STATIC int
outlist_int(const char *a, const char *b, char **c)
{
dTHX;
STRLEN lena = strlen(a);
STRLEN lenb = strlen(b);
STRLEN lenc = lena + lenb;
Newx(*c, lenc+1, char);
strcpy(*c, a);
strcat(*c, b);
SAVEFREEPV(*c);

return 11;
}

STATIC int
len(const char* const s, int const l){
PERL_UNUSED_ARG(s);
Expand Down Expand Up @@ -201,6 +231,12 @@ CLEANUP:
void
outlist(OUTLIST int a, OUTLIST int b)

bool
outlist_bool(const char *a, const char *b, OUTLIST char *c)

int
outlist_int(const char *a, const char *b, OUTLIST char *c)

int
len(char* s, int length(s))

Expand Down

0 comments on commit 8e7414c

Please sign in to comment.