Allow CStruct pass-by-value in Nativecall

lib/NativeCall.pm6

@@ -66,6 +66,7 @@ sub param_hash_for(Parameter $p) {
     my $type := $p.type();
     nqp::bindkey($result, 'typeobj', nqp::decont($type));
     nqp::bindkey($result, 'rw', nqp::unbox_i(1)) if $p.rw;
+    nqp::bindkey($result, 'copy', nqp::unbox_i(1)) if $p.copy;
     if $type ~~ Str {
         my $enc := $p.?native_call_encoded() || 'utf8';
         nqp::bindkey($result, 'type', nqp::unbox_s(string_encoding_to_nci_type($enc)));
@@ -74,7 +75,7 @@ sub param_hash_for(Parameter $p) {
     elsif $type ~~ Callable {
         nqp::bindkey($result, 'type', nqp::unbox_s(type_code_for($type)));
         my $info := param_list_for($p.sub_signature);
-        nqp::unshift($info, return_hash_for($p.sub_signature, :with-typeobj));
+        nqp::unshift($info, return_hash_for($p.sub_signature, :with-typeobj, :is-copy($p.copy)));
         nqp::bindkey($result, 'callback_args', $info);
     }
     else {
@@ -104,11 +105,12 @@ sub param_list_for(Signature $sig, &r?) {
 }
 
 # Builds a hash of type information for the specified return type.
-sub return_hash_for(Signature $s, &r?, :$with-typeobj, :$entry-point) {
+sub return_hash_for(Signature $s, &r?, :$with-typeobj, :$entry-point, :$is-copy) {
     my Mu $result := nqp::hash();
     my $returns := $s.returns;
-    nqp::bindkey($result, 'typeobj',     nqp::decont($returns))     if $with-typeobj;
+    nqp::bindkey($result, 'typeobj',     nqp::decont($returns))     if $with-typeobj or $is-copy;
     nqp::bindkey($result, 'entry_point', nqp::decont($entry-point)) if $entry-point;
+    nqp::bindkey($result, 'copy',        nqp::unbox_i(1))           if $is-copy;
     if $returns ~~ Str {
         my $enc := &r.?native_call_encoded() || 'utf8';
         nqp::bindkey($result, 'type', nqp::unbox_s(string_encoding_to_nci_type($enc)));
@@ -203,6 +205,10 @@ multi sub map_return_type($type) {
                             !! nqp::istype($type, Num) ?? Num !! $type;
 }
 
+my role CopyReturnStruct {
+    method ret-struct-copy(--> 1) { }
+}
+
 my role NativeCallSymbol[Str $name] {
     method native_symbol()  { $name }
 }
@@ -289,7 +295,7 @@ our role Native[Routine $r, $libname where Str|Callable|List|IO::Path|Distributi
                 nqp::unbox_s(gen_native_symbol($r, :$!cpp-name-mangler)), # symbol to call
                 nqp::unbox_s($conv),        # calling convention
                 $arg_info,
-                return_hash_for($r.signature, $r, :$!entry-point));
+                return_hash_for($r.signature, $r, :$!entry-point, :is-copy(self.does(CopyReturnStruct))));
             $!rettype := nqp::decont(map_return_type($r.returns)) unless $!rettype;
             $!arity = $r.signature.arity;
 
@@ -619,6 +625,10 @@ multi trait_mod:<is>(Routine $r, :$nativeconv!) is export(:DEFAULT, :traits) {
     $r does NativeCallingConvention[$nativeconv];
 }
 
+multi trait_mod:<is>(Routine $r, :$copy!) is export(:DEFAULT, :traits) {
+    $r does CopyReturnStruct;
+}
+
 # Ways to specify how to marshall strings.
 multi trait_mod:<is>(Parameter $p, :$encoded!) is export(:DEFAULT, :traits) {
     $p does NativeCallEncoded[$encoded];

t/04-nativecall/23-copy-args.c

@@ -0,0 +1,54 @@
+#include <stdlib.h>
+#ifdef _WIN32
+#define DLLEXPORT __declspec(dllexport)
+#else
+#define DLLEXPORT extern
+#endif
+
+#include <stdint.h>
+
+struct Simple {
+    int64_t bigint;
+    int32_t smallint;
+    float   smallnum;
+};
+
+DLLEXPORT float PassSimple(struct Simple x) {
+    return x.smallnum * x.bigint * x.smallint;
+}
+
+DLLEXPORT struct Simple ReturnsSimple(float x) {
+    struct Simple retval;
+    retval.smallnum = x;
+    return retval;
+}
+
+DLLEXPORT void TakeStructSimpleCopyCallback(void (*cb)(struct Simple), float x) {
+    struct Simple s;
+    s.smallnum = x;
+    cb(s);
+}
+
+DLLEXPORT float CheckReturnsStructSimpleCopy(struct Simple (*cb)(int32_t, float), int32_t x, float y) {
+    struct Simple r = cb(x, y);
+    return r.smallnum * r.bigint;
+}
+
+struct Point {
+    float x;
+    float y;
+};
+
+struct Size {
+    float width;
+    float height;
+};
+
+struct Rect {
+    struct Point origin;
+    struct Size  size;
+};
+
+DLLEXPORT float PassRect(struct Rect obj) {
+    return obj.origin.x + obj.origin.y + obj.size.width * obj.size.height;
+}

t/04-nativecall/23-copy-args.t

@@ -0,0 +1,68 @@
+use v6;
+
+use lib <lib t/04-nativecall>;
+use CompileTestLib;
+use NativeCall;
+use Test;
+
+plan 6;
+
+compile_test_lib('23-copy-args');
+
+class Simple is repr("CStruct") {
+    has int64 $.bigint;
+    has int32 $.smallint;
+    has num32 $.smallnum;
+}
+
+class Point is repr("CStruct") {
+    has num32 $.x;
+    has num32 $.y;
+};
+
+class Size is repr("CStruct") {
+    has num32 $.width;
+    has num32 $.height;
+}
+
+class Rect is repr("CStruct") {
+    HAS Point $.origin;
+    HAS Size  $.size;
+
+    submethod BUILD(:$x = 0e0, :$y = 0e0, :$w = 0e0; :$h = 0e0) {
+	$!origin := Point.new(:$x, :$y);
+	$!size   := Size.new(width => $w, height => $h);
+    }
+}
+
+
+sub PassSimple(Simple is copy --> num32)      is native('./23-copy-args') { * }
+sub ReturnsSimple(num32 --> Simple) is copy is native('./23-copy-args') { * }
+
+sub TakeStructSimpleCopyCallback(&cb (Simple is copy), num32) is native('./23-copy-args') { * }
+sub CheckReturnsStructSimpleCopy(&cb is copy (int32, num32 --> Simple), int32, num32 --> num32) is native('./23-copy-args') { * }
+
+sub PassRect(Rect is copy --> num32)    is native('./23-copy-args') { * }
+
+my $c = Simple.new(bigint => 1, smallint => 2, smallnum => 2e2);
+is-approx PassSimple($c), 4e2,        'Perl\'s struct is correctly passed by value';
+
+my $r = ReturnsSimple(4e-2);
+isa-ok $r, Simple,                    'Return value is of the right type';
+is-approx $r.smallnum, 4e-2,          'Returned the correct Struct value';
+
+sub struct_callback_copy(Simple $struct is copy) {
+    is-approx $struct.smallnum, 4e2,  'Callback got the Struct value';
+}
+TakeStructSimpleCopyCallback(&struct_callback_copy, 4e2);
+
+sub struct_callback_returns(int32 $a, num32 $b --> Simple) is copy {
+    return Simple.new(bigint => $a, smallnum => $b);
+}
+is-approx CheckReturnsStructSimpleCopy(&struct_callback_returns, 12, 2e2), 2400, 'Callback returned the Struct as copy';
+
+my $v = Rect.new(x => 2e2, y => 2e2, w => 2e1, h => 2e1);
+is-approx PassRect($v), 800, 'Can pass inlined CStruct around'; 
+
+# vim:ft=perl6
+