# New Ticket Created by Itsuki Toyota
# Please include the string: [perl #130187]
# in the subject line of all future correspondence about this issue.
# <URL: https://rt.perl.org/Ticket/Display.html?id=130187 >
See the following codes and results:
*** codes ***
* t/05-pointer.c
----
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include "05-pointer.h"
#ifdef _WIN32
#define DLLEXPORT __declspec(dllexport)
#else
#define DLLEXPORT extern
#endif
double dot(struct Feature* lhs, struct Feature* rhs) {
double sum = 0.0;
while(lhs->index != -1 && rhs->index != -1) {
if (lhs->index == rhs->index) {
sum += lhs->value * rhs->value;
lhs++;
rhs++;
}
else if (lhs->index < rhs->index) {
lhs++;
}
else {
rhs++;
}
}
return sum;
}
----
*t/05-pointer.h
----
#if ! defined(HEADER_POINTER_H)
#define HEADER_POINTER_H
#ifdef __cplusplus
extern "C" {
#endif
struct Feature {
int index;
double value;
} Feature;
double dot(struct Feature*, struct Feature*);
#ifdef __cplusplus
} /* closing brace for extern "C" */
#endif
#endif /* HEADER_POINTER_H */
----
* t/CompileTestLib.pm
----
unit module CompileTestLib;
my @cleanup; # files to be cleaned up afterwards
sub compile_test_lib($name) is export {
my ($c_line, $l_line);
my $VM := $*VM;
my $cfg := $VM.config;
my $libname = $VM.platform-library-name($name.IO);
if $VM.name eq 'moar' {
my $o = $cfg<obj>;
# MoarVM exposes exposes GNU make directives here, but we cannot pass
this to gcc directly.
my $ldshared = $cfg<ldshared>.subst(/'--out-implib,lib$(notdir $@).a'/,
"--out-implib,$libname.a");
$c_line = "$cfg<cc> -c $cfg<ccshared> $cfg<ccout>$name$o $cfg<cflags>
t/$name.c";
$l_line = "$cfg<ld> $ldshared $cfg<ldflags> $cfg<ldlibs>
$cfg<ldout>$libname $name$o";
@cleanup = << "$libname" "$name$o" >>;
}
elsif $VM.name eq 'jvm' {
$c_line = "$cfg<nativecall.cc> -c $cfg<nativecall.ccdlflags>
-o$name$cfg<nativecall.o> $cfg<nativecall.ccflags> t/04-nativecall/$name.c";
$l_line = "$cfg<nativecall.ld> $cfg<nativecall.perllibs>
$cfg<nativecall.lddlflags> $cfg<nativecall.ldflags>
$cfg<nativecall.ldout>$libname $name$cfg<nativecall.o>";
@cleanup = << $libname "$name$cfg<nativecall.o>" >>;
}
else {
die "Unknown VM; don't know how to compile test libraries";
}
shell($c_line);
shell($l_line);
}
sub compile_cpp_test_lib($name) is export {
my @cmds;
my $VM := $*VM;
my $cfg := $VM.config;
my $libname = $VM.platform-library-name($name.IO);
@cleanup = $libname;
if $*DISTRO.is-win {
@cmds = "cl /LD /EHsc /Fe$libname t/$name.cpp",
"g++ --shared -fPIC -o $libname t/$name.cpp",
}
else {
@cmds = "g++ --shared -fPIC -o $libname t/$name.cpp",
"clang++ -stdlib=libc++ --shared -fPIC -o $libname
t/$name.cpp",
}
my (@fails, $succeeded);
for @cmds -> $cmd {
my $handle = shell("$cmd 2>&1", :out);
my $output = $handle.out.slurp-rest;
if $handle.out.close.status {
@fails.push: "Running '$cmd':\n$output"
}
else {
$succeeded = 1;
last
}
}
fail @fails.join('=' x 80 ~ "\n") unless $succeeded;
}
END {
# say "cleaning up @cleanup[]";
unlink @cleanup;
}
----
* t/05-pointer.t
----
use v6;
use Test;
use NativeCall;
use lib <lib t>;
use CompileTestLib;
compile_test_lib('05-pointer');
class Feature is repr('CStruct') {
has int32 $.index;
has num64 $.value;
}
my sub dot(Feature, Feature) returns num64 is native("./05-pointer") { * }
my CArray[Feature] $lhs .= new;
my CArray[Feature] $rhs .= new;
$lhs[5] = Feature.new(index => -1, value => 0e0);
$rhs[5] = Feature.new(index => -1, value => 0e0);
for 1..5 -> $index {
$rhs[$index - 1] = Feature.new(index => $index, value => 2.5e0);
$lhs[$index - 1] = Feature.new(index => $index, value => 2.5e0);
}
for ^5 {
is $lhs[$_].value, 2.5e0, "\$lhs[$_].value = 2.5e0";
is $rhs[$_].value, 2.5e0, "\$rhs[$_].value = 2.5e0";
is $lhs[$_].index, $_ + 1, "\$lhs[$_].index = {$_ + 1}";
is $rhs[$_].index, $_ + 1, "\$rhs[$_].index = {$_ + 1}";
}
is dot($lhs[0], $rhs[0]), [+] ((2.5 * 2.5) xx 5);
done-testing;
----
*** results ***
----
$ mi6 test -v t/05-pointer.t
==> Set PERL6LIB=/home/itoyota/Programs/p6-Foo/lib
==> prove -e /home/itoyota/.rakudobrew/bin/../moar-nom/install/bin/perl6 -r -v
t/05-pointer.t
t/05-pointer.t ..
ok 1 - $lhs[0].value = 2.5e0
ok 2 - $rhs[0].value = 2.5e0
ok 3 - $lhs[0].index = 1
ok 4 - $rhs[0].index = 1
ok 5 - $lhs[1].value = 2.5e0
ok 6 - $rhs[1].value = 2.5e0
ok 7 - $lhs[1].index = 2
ok 8 - $rhs[1].index = 2
ok 9 - $lhs[2].value = 2.5e0
ok 10 - $rhs[2].value = 2.5e0
ok 11 - $lhs[2].index = 3
ok 12 - $rhs[2].index = 3
ok 13 - $lhs[3].value = 2.5e0
ok 14 - $rhs[3].value = 2.5e0
ok 15 - $lhs[3].index = 4
ok 16 - $rhs[3].index = 4
ok 17 - $lhs[4].value = 2.5e0
ok 18 - $rhs[4].value = 2.5e0
ok 19 - $lhs[4].index = 5
ok 20 - $rhs[4].index = 5
not ok 21 -
# Failed test at t/05-pointer.t line 33
# expected: '31.25'
# got: '6.25'
1..21
# Looks like you failed 1 test of 21
Dubious, test returned 1 (wstat 256, 0x100)
Failed 1/21 subtests
Test Summary Report
-------------------
t/05-pointer.t (Wstat: 256 Tests: 21 Failed: 1)
Failed test: 21
Non-zero exit status: 1
Files=1, Tests=21, 1 wallclock secs ( 0.02 usr 0.00 sys + 0.51 cusr 0.06
csys = 0.59 CPU)
Result: FAIL
----
In the above example, dot method accepts entry address of given two vectors and
computes the dot product of the values they have.
Hence, in the test case 21, dot($lhs[0],$rhs[0]) should return 31.25e0, where
$lhs[0] is the entry address of the CArray[Feature] (the values it has are
2.5e0 xx 5) and $rhs[0] is the entry address of the other CArray[Feature] (the
values it has are 2.5e0 xx 5).
However, in fact, it returns 6.25e0.
It seems that dot function in C side receive the entry address of the given
vector correctly, but it fails in incrementing the pointer address and points a
irrelevant address, because CArray cannot allocate contiguous memory.
I think that NativeCall needs something for allocating contiguous memory.
(I faced this type of error while creating a libsvm bindings for Perl 6:
https://github.com/cjlin1/libsvm/blob/master/svm.cpp#L294-L314 )
$ perl6 --version
This is Rakudo version 2016.10-309-g3dcc52b built on MoarVM version
2016.10-71-g9d5c874
implementing Perl 6.c.
