XS: fix INTERFACE on strict C compilers

GH #23192

The INTERFACE keyword in XS allows the same XSUB to wrap multiple C
library functions, by storing a function pointer to the C function in
each CV.

This has started failing on some strict C compilers, as the C code
generated by the XS compiler does some suspect function pointer casts.

This commit fixes the issue by providing a more correct cast in most
cases (it still can't handle non-trivial C_ARGS values).

Background:

Before this commit, the presence of the INTERFACE keyword in this XSUB:

    char*
    foo(int a, int b, int c)
        INTERFACE: bar baz

would cause these extra lines to be added to the XSUB's body:

    dXSFUNCTION(char*);
    XSFUNCTION = XSINTERFACE_FUNC(char*,cv,XSANY.any_dptr);
    RETVAL = XSFUNCTION(a, b, c);

and lines like this to be added to the boot XSUB:

    XSINTERFACE_FUNC_SET(cv,bar);

After macro expansion, these lines look roughly like the following:

    char* (*XSFUNCTION)();
    XSFUNCTION = (char* (*)()))(XSANY.any_dptr));
    RETVAL = XSFUNCTION(a, b, c);

    CvXSUBANY(cv).any_dxptr = (void (*) (pTHX_ void*))(bar);

The issue:

The specific error the C compiler is giving in the ticket is:

    error: too many arguments to function ‘XSFUNCTION’

which is caused by this line:

    RETVAL = XSFUNCTION(a, b, c);

because XSFUNCTION has been declared as a pointer to a function
which has no args, and is now being used as a pointer to a function
which takes args.

The fix:

This commit fixes this issue by adding adding a cast: but only to the
place where XSFUNCTION is used to call the function. The other places
are left untouched (so the XSFUNCTION variable itself still has the
"wrong" type). This has the advantage that the various dXSFUNCTION etc
macros in XSUB.h don't need to be modified, and so portability to older
Perls is less of an issue. It also means that INTERFACE_MACRO usage
should be unaffected.

After this commit, the code emitted to call XSFUNCTION now looks like:

    RETVAL = ((char* (*)(int,int,int))(XSFUNCTION))(a, b, c);

This cast is generated based on the types of the XSUB's parameters and
return values.

Things are difficult in the presence of C_ARGS; for example,

    char*
    foo(int a, int b, int c)
        INTERFACE: bar baz
        C_ARGS: a, c

In this case, the XS parser now splits the C_ARGS line and looks up the
type of each corresponding parameter. If it can't be found, it uses
'void *' instead and hopes for the best.

For more complex C_ARGS entries such as

    C_ARGS: foo(a), b+1

this doesn't work and it is likely that uncompilable C code will still
be generated,

This commit adds tests both to 001-basic.t (which just checks that the
generated C code looks as expected), but also to 002-more.t, which
actually compiles and executes the C code, and thus is more likely to
catch failures due to picky C compilers.

Author: iabyn

dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS/Node.pm

@@ -2569,14 +2569,18 @@ sub usage_string {
 
 # $self->C_func_signature():
 #
-# return a string containing the arguments to pass to an autocall C
-# function, e.g. 'a, &b, c'.
+# return two arrays
+# the first contains the arguments to pass to an autocall C
+# function, e.g. ['a', '&b', 'c'];
+# the second contains the types of those args, for use in declaring
+# a function pointer type, e.g. ['int', 'char*', 'long'].
 
 sub C_func_signature {
     my __PACKAGE__       $self = shift;
     my ExtUtils::ParseXS $pxs  = shift;
 
     my @args;
+    my @types;
     for my $param (@{$self->{kids}}) {
         next if    $param->{is_synthetic} # THIS/CLASS/RETVAL
                    # if a synthetic RETVAL has acquired an arg_num, then
@@ -2586,6 +2590,7 @@ sub C_func_signature {
 
         if ($param->{is_length}) {
             push @args, "XSauto_length_of_$param->{len_name}";
+            push @types, $param->{type};
             next;
         }
 
@@ -2606,9 +2611,11 @@ sub C_func_signature {
         my $a = $param->{var};
         $a = "&$a" if $param->{is_addr} or $io =~ /OUT/;
         push @args, $a;
+        my $t = $param->{type};
+        push @types, defined $t ? $t : 'void*';
     }
 
-    return join(", ", @args);
+    return \@args, \@types;
 }
 
 
@@ -3325,7 +3332,8 @@ package ExtUtils::ParseXS::Node::autocall;
 # name
 
 BEGIN { $build_subclass->(
-    'args', # Str: text to use for auto function call arguments
+    'args',  # Str: text to use for auto function call arguments
+    'types', # Str: text to use for auto function type declaration
 )};
 
 
@@ -3340,10 +3348,35 @@ sub parse {
     $xbody->{seen_autocall} = 1;
 
     my $ioparams  = $xbody->{ioparams};
-    my $args = $ioparams->{auto_function_sig_override}; # C_ARGS
-    $args = $ioparams->C_func_signature($pxs)
-        unless defined $args;
-    $self->{args} = $args;
+    my ($args, $types);
+    $args = $ioparams->{auto_function_sig_override}; # C_ARGS
+    if (defined $args) {
+        # Try to determine the C_ARGS types; for example, with
+        #
+        #    foo(short s, int i, long l)
+        #      C_ARGS: s, l
+        #
+        # set $types to ['short', 'long']. May give the wrong results if
+        # C_ARGS isn't just a simple list of parameter names
+        for my $var (split /,/, $args) {
+            $var =~ s/^\s+//;
+            $var =~ s/\s+$//;
+            my $param = $ioparams->{names}{$var};
+            # 'void*' is a desperate guess if no such parameter
+            push @$types, ($param && defined $param->{type})
+                            ? $param->{type} : 'void*';
+        }
+        $self->{args}  = $args;
+    }
+    else {
+        ($args, $types) = $ioparams->C_func_signature($pxs);
+        $self->{args}  = join ', ', @$args;
+    }
+
+    unless ($pxs->{config_RetainCplusplusHierarchicalTypes}) {
+        s/:/_/g for @$types;
+    }
+    $self->{types} = join ', ', @$types;
 
     1;
 }
@@ -3375,7 +3408,8 @@ sub as_code {
 
         print "\n\t";
 
-        if ($xsub->{decl}{return_type}{type} ne "void") {
+        my $ret_type = $xsub->{decl}{return_type}{type};
+        if ($ret_type ne "void") {
             print "RETVAL = ";
         }
 
@@ -3404,9 +3438,13 @@ sub as_code {
         $name =~ s/^\Q$strip//
             if defined $strip;
 
-        $name = 'XSFUNCTION'
-            if    $xsub->{seen_INTERFACE}
-               or $xsub->{seen_INTERFACE_MACRO};
+        if (   $xsub->{seen_INTERFACE}
+            or $xsub->{seen_INTERFACE_MACRO})
+        {
+            $ret_type =~ s/:/_/g
+                unless $pxs->{config_RetainCplusplusHierarchicalTypes};
+            $name = "(($ret_type (*)($self->{types}))(XSFUNCTION))";
+        }
 
         print "$name($self->{args});\n";
 

dist/ExtUtils-ParseXS/t/001-basic.t

@@ -4811,6 +4811,10 @@ EOF
         |
         |PROTOTYPES:  DISABLE
         |
+        |TYPEMAP: <<EOTM
+        |X::Y T_IV
+        |EOTM
+        |
 EOF
 
     my @test_fns = (
@@ -4825,25 +4829,36 @@ EOF
                    "got XSFUNCTION declaration" ],
             [ 0, 0, qr{\QXSFUNCTION = XSINTERFACE_FUNC(void,cv,XSANY.any_dptr);},
                    "got XSFUNCTION assign" ],
-            [ 0, 0, qr{\bXSFUNCTION\(\)},
+            [ 0, 0, qr{\Q((void (*)())(XSFUNCTION))();},
                    "got XSFUNCTION call" ],
         ],
         [
             'INTERFACE with perl package name',
             [ Q(<<'EOF') ],
-                |TYPEMAP: <<EOTM
-                |X::Y T_IV
-                |EOTM
-                |
                 |X::Y
-                |foo()
+                |foo(X::Y a, char *b)
                 |    INTERFACE: f1
 EOF
             [ 0, 0, qr{\b\QdXSFUNCTION(X__Y)},
                    "got XSFUNCTION declaration" ],
             [ 0, 0, qr{\QXSFUNCTION = XSINTERFACE_FUNC(X__Y,cv,XSANY.any_dptr);},
                    "got XSFUNCTION assign" ],
-            [ 0, 0, qr{\bXSFUNCTION\(\)},
+            [ 0, 0, qr{\QRETVAL = ((X__Y (*)(X__Y, char *))(XSFUNCTION))(a, b);},
+                   "got XSFUNCTION call" ],
+        ],
+        [
+            'INTERFACE with C_ARGS',
+            [ Q(<<'EOF') ],
+                |char *
+                |foo(X::Y a, int b, char *c)
+                |    INTERFACE: f1
+                |    C_ARGS:  a,  c
+EOF
+            [ 0, 0, qr{\b\QdXSFUNCTION(char *)},
+                   "got XSFUNCTION declaration" ],
+            [ 0, 0, qr{\QXSFUNCTION = XSINTERFACE_FUNC(char *,cv,XSANY.any_dptr);},
+                   "got XSFUNCTION assign" ],
+            [ 0, 0, qr{\QRETVAL = ((char * (*)(X__Y, char *))(XSFUNCTION))(a,  c);},
                    "got XSFUNCTION call" ],
         ],
     );

dist/ExtUtils-ParseXS/t/002-more.t

@@ -9,7 +9,7 @@ use ExtUtils::CBuilder;
 use attributes;
 use overload;
 
-plan tests => 33;
+plan tests => 35;
 
 my ($source_file, $obj_file, $lib_file);
 
@@ -47,7 +47,7 @@ SKIP: {
 }
 
 SKIP: {
-  skip "no dynamic loading", 29
+  skip "no dynamic loading", 31
     if !$b->have_compiler || !$Config{usedl};
   my $module = 'XSMore';
   $lib_file = $b->link( objects => $obj_file, module_name => $module );
@@ -113,6 +113,9 @@ SKIP: {
   is XSMore::typemaptest3(12, 13, 14), 12, 'Simple embedded typemap works for input, too';
   is XSMore::typemaptest6(5), 5, '<<END; (with semicolon) matches delimiter "END"';
 
+  is XSMore::myadd1(5,7),     12, 'INTERFACE: myadd1';
+  is XSMore::myadd2(5,99,13), 18, 'INTERFACE: myadd2, C_ARGS';
+
   # Win32 needs to close the DLL before it can unlink it, but unfortunately
   # dl_unload_file was missing on Win32 prior to perl change #24679!
   if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {

dist/ExtUtils-ParseXS/t/XSMore.xs

@@ -78,6 +78,15 @@ len(const char* const s, int const l){
 	return l;
 }
 
+STATIC int
+myadd1(int a, int b)
+{ return a + b; }
+
+STATIC int
+myadd2(int a, int b)
+{ return a + b; }
+
+
 MODULE = XSMore         PACKAGE = XSMore
 
 =for testing
@@ -244,6 +253,15 @@ outlist_int(const char *a, const char *b, OUTLIST char *c)
 int
 len(char* s, int length(s))
 
+int
+interface1(int a, int b)
+    INTERFACE: myadd1
+
+int
+interface2(int a, int b, int c)
+    INTERFACE: myadd2
+    C_ARGS: a, c
+
 INCLUDE_COMMAND: $^X -Ilib -It/lib -MIncludeTester -e IncludeTester::print_xs
 
 #if 1