This problem was brought up in #115796. Both of those lines of code that
ParseXS put out when dealing with T_BOOL were unnecessary, and caused a
some inefficiencies (extra calls). Since typemaps can have complicated
evaluation and include Perl code, see commit
9712754a3e, it is best to
eval the typemap entry first, then regexp it to see what it looks like,
not regexp the unevaled entry possibly containing Perl. In case a typemap
entry is maintaining state inside ParseXS (venturing into the undocumented
and unsupported), (I've never seen it done) don't eval it twice if it can
be avoided. Someone might want to change the typemap entry to multiple
eval in the future, but don't introduce it now if it can be avoided.
Using T_BOOL by name to see an immortal is a bad idea, since any XS module
can reuse the typemap entry, so best to regexp for something that looks
like it would return an immortal, "= &PL_sv_* ;" or "= boolSV(". In the
future someone might want to introduce a macro that does nothing, except
gives a signal to ParseXS that an expression returns an immortal or an
already mortaled SV, to suppress the sv_2mortal call.
The tests in 001-basic.t might break in the future with changes to ParseXS
or the Perl API, but I assume they will be fixed at that point in time.
Note: This patch was amended by the committer to apply cleanly to a
newer version of ExtUtils::ParseXS and to include all necessary test
changes.
Revision history for Perl extension ExtUtils::ParseXS.
+ - stop "sv_2mortal(&PL_sv_yes)" and "(void)sv_newmortal()" for immortal
+ typemap entries [perl #116152]
+
3.18_03 - Fri Apr 19 18:40:00 CET 2013
- Heuristic (and flawed) type canonicalization for templated
C++ types.
print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
}
elsif ($var eq 'RETVAL') {
- if ($expr =~ /^\t\$arg = new/) {
+ my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars);
+ if ($expr =~ /^\t\Q$arg\E = new/) {
# We expect that $arg has refcnt 1, so we need to
# mortalize it.
- $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars);
+ print $evalexpr;
print "\tsv_2mortal(ST($num));\n";
print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
}
- elsif ($expr =~ /^\s*\$arg\s*=/) {
+ # If RETVAL is immortal, don't mortalize it. This code is not perfect:
+ # It won't detect a func or expression that only returns immortals, for
+ # example, this RE must be tried before next elsif.
+ elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) {
+ print $evalexpr;
+ }
+ elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) {
# We expect that $arg has refcnt >=1, so we need
# to mortalize it!
- $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars);
+ print $evalexpr;
print "\tsv_2mortal(ST(0));\n";
print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
}
# Just hope that the entry would safely write it
# over an already mortalized value. By
# coincidence, something like $arg = &sv_undef
- # works too.
+ # works too, but should be caught above.
print "\tST(0) = sv_newmortal();\n";
- $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars);
+ print $evalexpr;
# new mortals don't have set magic
}
}
#!/usr/bin/perl
use strict;
-use Test::More tests => 11;
+use Test::More tests => 14;
use Config;
use DynaLoader;
use ExtUtils::CBuilder;
while (my $l = <$IN>) {
$seen++ if $l =~ m/#line\s1\s/;
}
+is( $seen, 1, "Line numbers created in output file, as intended" );
+{
+ #rewind .c file and regexp it to look for code generation problems
+ local $/ = undef;
+ seek($IN, 0, 0);
+ my $filecontents = <$IN>;
+ my $good_T_BOOL_re =
+qr|\QXS_EUPXS(XS_XSTest_T_BOOL)\E
+.+?
+#line \d+\Q "XSTest.c"
+ ST(0) = boolSV(RETVAL);
+ }
+ XSRETURN(1);
+}
+\E|s;
+ like($filecontents, $good_T_BOOL_re, "T_BOOL doesn\'t have an extra sv_newmortal or sv_2mortal");
+
+ my $good_T_BOOL_2_re =
+qr|\QXS_EUPXS(XS_XSTest_T_BOOL_2)\E
+.+?
+#line \d+\Q "XSTest.c"
+ sv_setsv(ST(0), boolSV(in));
+ SvSETMAGIC(ST(0));
+ }
+ XSRETURN(1);
+}
+\E|s;
+ like($filecontents, $good_T_BOOL_2_re, 'T_BOOL_2 doesn\'t have an extra sv_newmortal or sv_2mortal');
+ my $good_T_BOOL_OUT_re =
+qr|\QXS_EUPXS(XS_XSTest_T_BOOL_OUT)\E
+.+?
+#line \d+\Q "XSTest.c"
+ sv_setsv(ST(0), boolSV(out));
+ SvSETMAGIC(ST(0));
+ }
+ XSRETURN_EMPTY;
+}
+\E|s;
+ like($filecontents, $good_T_BOOL_OUT_re, 'T_BOOL_OUT doesn\'t have an extra sv_newmortal or sv_2mortal');
+
+}
close $IN or die "Unable to close $source_file: $!";
-is( $seen, 1, "Linenumbers created in output file, as intended" );
unless ($ENV{PERL_NO_CLEANUP}) {
for ( $obj_file, $lib_file, $source_file) {
OUTPUT:
RETVAL
+bool
+T_BOOL(in)
+ bool in
+ CODE:
+ RETVAL = in;
+ OUTPUT: RETVAL
+
+bool
+T_BOOL_2(in)
+ bool in
+ CODE:
+ OUTPUT: in
+
+void
+T_BOOL_OUT( out, in )
+ bool out
+ bool in
+ CODE:
+ out = in;
+ OUTPUT: out
T_ENUM
sv_setiv($arg, (IV)$var);
T_BOOL
- $arg = boolSV($var);
+ ${"$var" eq "RETVAL" ? \"$arg = boolSV($var);" : \"sv_setsv($arg, boolSV($var));"}
T_U_INT
sv_setuv($arg, (UV)$var);
T_SHORT
projects / platform / upstream / perl.git / commitdiff