Perl Win32::API - 将数组传入和传出 DLL 函数的问题

Question

系统环境：64位Windows 7 Ultimate；活动状态 Perl 修订版 5 版本 24 颠覆 3； Build 2404 [404865] 于 2017 年 12 月 11 日 11:09:26 编译。

我正在尝试编写一个 perl 脚本来调用声明为的函数：

extern "C" POLYFITGSL_API int PolyFit(int numPts, const double* xVals, const double* yVals, int fitOrder, double* coef, double* fitVals, double* rSquared);

前四个参数是 PolyFit 的输入，后三个是输出。

在 C 程序中分配了指针，以这种形式调用它：

 coef = (double*)malloc((fitOrder + 1) * sizeof(double));
 estYVals = (double*)malloc(n * sizeof(double));
 rSquared = (double*)malloc(sizeof(double));
 resFit = PolyFit(n, xVals, yVals, fitOrder, coef, estYVals, rSquared);

DLL 导出：DSL Viewer display

使用参数列表选项的尝试未成功。此外，https://metacpan.org/pod/Win32::API#1 建议按原型导入。但是我不知道怎么写，也找不到例子。

使用下面代码片段中的参数列表选项，除了两个整数之外，都定义为指针，并且对于输出，引用的数组和最终的浮点数已预先定义并填充为零。

# This assumes that the integers are 4 bytes wide and all others are 8:
$returnbuf = " " x 48;
$parmsbuf = " " x 48;

my $PolyFit = Win32::API::More->new('D:/prjct/model/code/SRS1/binaries/PolyFitGSL','PolyFit','PNP','N');
die $! unless defined $PolyFit;
# no error is produced here

$parmsbuf = pack('iNNiNNN', $numvals, $xValsptr, $yValsptr, $fitorder, $coeffsptr, $fitValsptr, $rSquaredptr);

# display the parameters
@outref = unpack('iNNiNNN', $parmsbuf);
print ("The unpacked calling buffer:  @outref \n");

$returncode = $PolyFit ->Call($parmsbuf, 3, $returnbuf);
# the return value is 52

$error = Win32::GetLastError();
if ($error) {print("function call failed: $^E \n")};

@returnvals = unpack('iNNiNNN', $returnbuf);
print ("Return values:  @returnvals \n");

在执行时，这会产生： 解压后的调用缓冲区：600 58497768 58498512 3 58497816 58497840 58489400

返回值：538976288 538976288 538976288 538976288 538976288 538976288 538976288

在所有测试条件下调用的返回值都是52。

$coeffsptr、$fitValsptr 和 $rSquaredptr 引用的输出数组和标量保持其初始化状态。

输入缓冲区的值在我看来是正确的，指针值看起来像是 perl 地址空间中的合理位置。

没有检测到执行错误，但返回的值显然是无效的。我在这里犯了错误，但对我来说如何解决它们并不明显。

关于参数类型标识符的权威机构之间存在分歧。 https://metacpan.org/pod/Win32::API#1 表示使用 D 指定了双浮点数，但 pack 函数将其视为无效类型而拒绝。

我依靠这个来源来指定 GSL PolyFit 函数所期望的变量的大小：https://www.ibm.com/support/knowledgecenter/en/SSFKSJ_9.0.0/com.ibm.mq.ref.dev.doc/q104610_.htm

如果我应该通过原型导入，那么如何编写导入和调用语句的示例将非常有价值。我不是开发人员，我只是想完成一些科学工作，快速多项式拟合程序至关重要。 GSL PolyFit 函数可以在这台 3.5 GHz、有 7 年历史的计算机上在大约 350 微秒内将三次多项式拟合到 600 个数据点。

非常感谢您的帮助；

Answer 1

很多问题。

• PNP 对于有 7 个参数的函数显然是错误的。
• 同样，->Call($parmsbuf, 3, $returnbuf) 是怎么回事？
• N 不是正确的返回值类型。
• Win32::API 默认使用stdcall 调用约定，但该函数似乎使用cdecl 调用约定。

您可以使用以下内容：（注释如下）

use feature qw( state );

use Config     qw( %Config );
use Win32::API qw( );


use constant PTR_SIZE => $Config{ptrsize};

use constant PTR_PACK_FORMAT =>
     PTR_SIZE == 8 ? 'Q'
   : PTR_SIZE == 4 ? 'L'
   : die("Unrecognized ptrsize\n");

use constant PTR_WIN32API_TYPE =>
     PTR_SIZE == 8 ? 'DWORD64'
   : PTR_SIZE == 4 ? 'DWORD32'
   : die("Unrecognized ptrsize\n");
   
Win32::API::Type->typedef('uintptr_t' => PTR_WIN32API_TYPE);


my $dll = 'D:/prjct/model/code/SRS1/binaries/PolyFitGSL';


sub get_buffer_addr { unpack(PTR_PACK_FORMAT, pack('P', $_[0])) }


sub poly_fit {
   my ($vals, $fit_order) = @_;

   state $PolyFit;
   if (!$PolyFit) {
      my $adjusted_proto = '
         int __cdecl PolyFit(
            int numPts,
            uintptr_t xVals,
            uintptr_t yVals,
            int fitOrder,
            uintptr_t coef,
            uintptr_t fitVals,
            uintptr_t rSquared
         )
      ';
      
      $PolyFit = Win32::API::More->new($dll, $adjusted_proto)
         or die("Can't link to PolyFit: $^E\n");
   }

   my $n = @$vals;
   
   my $x_vals    = pack("d$n",                  map $_->[0], @$vals);
   my $y_vals    = pack("d$n",                  map $_->[1], @$vals);
   my $coef      = pack('d'.( $fit_order + 1 ), ( 0 )x( $fit_order + 1 ));
   my $fit_vals  = pack("d$n",                  ( 0 )x( $n ));
   my $r_squared = pack('d',                    0);

   my $rv = $PolyFit->Call(
      $n,
      get_buffer_addr($x_vals),
      get_buffer_addr($y_vals),
      $fit_order,
      get_buffer_addr($coef),
      get_buffer_addr($fit_vals),
      get_buffer_addr($r_squared),
   );

   # I'm assuming the return value indicates whether the call was successful or not?
   return if !$rv;

   return (
      [ unpack('d'.( $fit_order + 1 ), $coef)      ],
      [ unpack("d$n",                  $fit_vals)  ],
      [ unpack('d',                    $r_squared) ],
   );
}

my ($coef, $fit_vals, $r_squared) = poly_fit(
   [ [ $x1, $y1 ], [ $x2, $y2 ], [ $x3, $y3 ], ... ],
   $fit_order,
)
   or die("Error");

或者，如果您更喜欢使用并行数组作为输入，

sub poly_fit {
   my ($x_vals, $y_vals, $fit_order) = @_;
   @$x_vals == @$y_vals
      or croak("Mismatch in the number of X vals and Y vals");

   ...

   my $n = @$x_vals;

   my $x_vals    = pack("d$n",                 @$x_vals);
   my $y_vals    = pack("d$n",                 @$y_vals);
   ...
}

my ($coef, $fit_vals, $r_squared) = poly_fit(
   [ $x1, $x2, $x3, ... ],
   [ $y1, $y2, $y3, ... ],
   $fit_order,
)
   or die("Error");

---

备注

当我编写上述代码时，我认为指定 __stdcall 以外的调用约定需要切换到 Win32:API 的原型语法。但我错了。我可以使用以下内容：

use constant PTR_WIN32API_TYPE =>
     PTR_SIZE == 8 ? 'Q'
   : PTR_SIZE == 4 ? 'N'
   : die("Unrecognized ptrsize\n");

$PolyFit = Win32::API::More->new(
   $dll, 'PolyFit', 'PPiPPP' =~ s/P/PTR_WIN32API_TYPE/ger, 'i', '__cdecl')

Win32::API 的原型解析器很蹩脚。当它看到const double* xVals 时，它看到const foo！而double* xVals 也好不到哪里去，因为它只会看到double foo;。

我们可以使用LPDOUBLE 代替double*，但这对我们没有太大帮助。无论是否使用原型语法，Win32::API 都希望我们提供一个单个数字，而不是一个数组。

所以我们自己处理指针。通过告诉 Win32::API 指针参数是适当大小的整数（DWORD32 或 DWORD64 取决于我们使用的是 32 位还是 64 位指针），我们可以传递指针而无需任何解释通过 Win32::API。

---

接下来是我的整个测试。

a.h

#ifndef A_H
#define A_H

#ifdef __cplusplus
extern "C" {
#endif

#ifdef POLYFITGSL_EXPORTS
#define POLYFITGSL_API __declspec(dllexport)
#else
#define POLYFITGSL_API __declspec(dllimport)
#endif

POLYFITGSL_API int PolyFit(int numPts, const double* xVals, const double* yVals, int fitOrder, double* coef, double* fitVals, double* rSquared);

#ifdef __cplusplus
}
#endif

#endif  // A_H

a.c

#include <stdio.h>
#include "a.h"

POLYFITGSL_API int PolyFit(int numPts, const double* xVals, const double* yVals, int fitOrder, double* coef, double* fitVals, double* rSquared) {
   // %I64u is MS-specific and shoulnd't be hardcoded.
   printf("[C] sizeof(int):     %I64u\n", sizeof(int));
   printf("[C] sizeof(double*): %I64u\n", sizeof(double*));

   printf("[C] numPts:   %d\n", numPts);
   printf("[C] xVals:    %p\n", (void*)xVals);
   printf("[C] yVals:    %p\n", (void*)yVals);
   printf("[C] fitOrder: %d\n", fitOrder);

   printf("[C] coef:     %p\n", (void*)coef);
   printf("[C] fitVals:  %p\n", (void*)fitVals);
   printf("[C] rSquared: %p\n", (void*)rSquared);


   for (int i=0; i<numPts; ++i) {
      printf("[C] xVals[%d]: %f\n", i, xVals[i]);
      printf("[C] yVals[%d]: %f\n", i, yVals[i]);
   }

   for (int i=0; i<fitOrder+1; ++i)
      coef[i] = (i+1)/10.0;

   for (int i=0; i<numPts; ++i)
      fitVals[i] = (i+1)/100.0;

   *rSquared = 3.14;

   return 1;
}

a.pl

#!perl

use 5.014;
use warnings;

use Config       qw( %Config );
use Data::Dumper qw( Dumper );
use Devel::Peek  qw( Dump );
use Win32::API   qw( );


use constant PTR_SIZE => $Config{ptrsize};

use constant PTR_PACK_FORMAT =>
     PTR_SIZE == 8 ? 'Q'
   : PTR_SIZE == 4 ? 'L'
   : die("Unrecognized ptrsize\n");

use constant PTR_WIN32API_TYPE =>
     PTR_SIZE == 8 ? 'DWORD64'
   : PTR_SIZE == 4 ? 'DWORD32'
   : die("Unrecognized ptrsize\n");
   
Win32::API::Type->typedef('uintptr_t' => PTR_WIN32API_TYPE);


my $dll = $0 =~ s/\.pl\z/.dll/r;


sub get_buffer_addr { unpack(PTR_PACK_FORMAT, pack('P', $_[0])) }


sub poly_fit {
   my ($vals, $fit_order) = @_;

   state $PolyFit;
   if (!$PolyFit) {
      my $adjusted_proto = '
         int __cdecl PolyFit(
            int numPts,
            uintptr_t xVals,
            uintptr_t yVals,
            int fitOrder,
            uintptr_t coef,
            uintptr_t fitVals,
            uintptr_t rSquared
         )
      ';
      
      $PolyFit = Win32::API::More->new($dll, $adjusted_proto)
         or die("Can't link to PolyFit: $^E\n");
   }

   my $n = @$vals;
   
   my $x_vals    = pack("d$n",                  map $_->[0], @$vals);
   my $y_vals    = pack("d$n",                  map $_->[1], @$vals);
   my $coef      = pack('d'.( $fit_order + 1 ), ( 0 )x( $fit_order + 1 ));
   my $fit_vals  = pack("d$n",                  ( 0 )x( $n ));
   my $r_squared = pack('d',                    0);

   printf("[Perl] sizeof(double*): %u\n", PTR_SIZE);

   printf("[Perl] numPts:   %d\n",    $n);
   printf("[Perl] xVals:    %016X\n", get_buffer_addr($x_vals));
   printf("[Perl] yVals:    %016X\n", get_buffer_addr($y_vals));
   printf("[Perl] fitOrder: %d\n",    $fit_order);

   printf("[Perl] coef:     %016X\n", get_buffer_addr($coef));
   printf("[Perl] fitVals:  %016X\n", get_buffer_addr($fit_vals));
   printf("[Perl] rSquared: %016X\n", get_buffer_addr($r_squared));

   Dump($coef);

   my $rv = $PolyFit->Call(
      $n,
      get_buffer_addr($x_vals),
      get_buffer_addr($y_vals),
      $fit_order,
      get_buffer_addr($coef),
      get_buffer_addr($fit_vals),
      get_buffer_addr($r_squared),
   );

   Dump($coef);

   # I'm assuming the return value indicates whether the call was successful or not?
   return if !$rv;

   return (
      [ unpack('d'.( $fit_order + 1 ), $coef)      ],
      [ unpack("d$n",                  $fit_vals)  ],
      [ unpack('d',                    $r_squared) ],
   );
}

my $fit_order = 4;

my ($coef, $fit_vals, $r_squared) = poly_fit(
   [ [ 14.5, 24.5 ], [ 15.5, 25.5 ], [ 15.5, 25.5 ] ],
   $fit_order,
)
   or die("Error");

print(Dumper($coef, $fit_vals, $r_squared));

a.bat

（这里使用的是 Strawberry Perl 安装的 mingw。）

@echo off
gcc -Wall -Wextra -pedantic -c -DPOLYFITGSL_EXPORTS a.c & gcc -shared -o a.dll a.o -Wl,--out-implib,liba.a & perl a.pl