Stop "sv_2mortal(&PL_sv_yes)" and "(void)sv_newmortal()" in ParseXS

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.

5 files changed, 79 insertions, 9 deletions

diff --git a/dist/ExtUtils-ParseXS/Changes b/dist/ExtUtils-ParseXS/Changes
index feb507a41e..54071a38ca 100644
--- a/dist/ExtUtils-ParseXS/Changes
+++ b/dist/ExtUtils-ParseXS/Changes
@@ -1,5 +1,8 @@
 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.
diff --git a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
index 3849339618..b75be2b454 100644
--- a/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
+++ b/dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm
@@ -1963,17 +1963,24 @@ sub generate_output {
       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;
       }
@@ -1981,9 +1988,9 @@ sub generate_output {
         # 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
       }
     }
diff --git a/dist/ExtUtils-ParseXS/t/001-basic.t b/dist/ExtUtils-ParseXS/t/001-basic.t
index 755be52aca..a1b9f1d933 100644
--- a/dist/ExtUtils-ParseXS/t/001-basic.t
+++ b/dist/ExtUtils-ParseXS/t/001-basic.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl
 
 use strict;
-use Test::More tests => 11;
+use Test::More tests => 14;
 use Config;
 use DynaLoader;
 use ExtUtils::CBuilder;
@@ -72,8 +72,48 @@ open my $IN, '<', $source_file
 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) {
diff --git a/dist/ExtUtils-ParseXS/t/XSTest.xs b/dist/ExtUtils-ParseXS/t/XSTest.xs
index 699c7341aa..89df22fab9 100644
--- a/dist/ExtUtils-ParseXS/t/XSTest.xs
+++ b/dist/ExtUtils-ParseXS/t/XSTest.xs
@@ -65,3 +65,23 @@ consts (myclass)
     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
diff --git a/dist/ExtUtils-ParseXS/t/typemap b/dist/ExtUtils-ParseXS/t/typemap
index 2c35437e34..85c830909a 100644
--- a/dist/ExtUtils-ParseXS/t/typemap
+++ b/dist/ExtUtils-ParseXS/t/typemap
@@ -240,7 +240,7 @@ T_SYSRET
 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