Failing Attempt at improving NativeCall (see second attached file)

NativeCall.pm6

use nqp;

module NativeCall {

use NativeCall::Types;
use NativeCall::Compiler::GNU;
use NativeCall::Compiler::MSVC;

#'{
my package EXPORT::DEFAULT {
	use NativeCall::Types;
}
my package EXPORT::types {
	use NativeCall::Types;
}
#}
my constant OpaquePointer is export(:types, :DEFAULT) = Pointer;

# Throwaway type just to get us some way to get at the NativeCall
# representation.
my class native_callsite is repr('NativeCall') { }

# Maps a chosen string encoding to a type recognized by the native call engine.
sub string_encoding_to_nci_type(\encoding) {
    my str $enc = encoding;
    nqp::iseq_s($enc,"utf8")
      ?? "utf8str"
      !! nqp::iseq_s($enc,"ascii")
        ?? "asciistr"
        !! nqp::iseq_s($enc,"utf16")
          ?? "utf16str"
          !! die "Unknown string encoding for native call: $enc"
}

# Builds a hash of type information for the specified parameter.
sub param_hash_for(Parameter $p, :$with-typeobj) {
    my Mu $result := nqp::hash();
    my $type := $p.type();
    nqp::bindkey($result, 'typeobj', nqp::decont($type)) if $with-typeobj;
    nqp::bindkey($result, 'rw', nqp::unbox_i(1)) if $p.rw;
    if $type ~~ Str {
        my $enc := $p.?native_call_encoded // 'utf8';
        nqp::bindkey($result, 'type', nqp::unbox_s(string_encoding_to_nci_type($enc)));
        nqp::bindkey($result, 'free_str', nqp::unbox_i(1));
    }
    elsif $type.?native_call_sub_signature -> $sub_signature {
        nqp::bindkey($result, 'type', nqp::unbox_s(type_code_for($type)));
        my $info := param_list_for($sub_signature, :with-typeobj);
        nqp::unshift($info, return_hash_for($sub_signature, :with-typeobj));
        nqp::bindkey($result, 'callback_args', $info);
    }
    elsif $type ~~ Callable {
        nqp::bindkey($result, 'type', nqp::unbox_s(type_code_for($type)));
        my $info := param_list_for($p.sub_signature, :with-typeobj);
        nqp::unshift($info, return_hash_for($p.sub_signature, :with-typeobj));
        nqp::bindkey($result, 'callback_args', $info);
    }
    else {
        nqp::bindkey($result, 'type', nqp::unbox_s(type_code_for($type)));
    }
    $result
}

# Builds the list of parameter information for a callback argument.
sub param_list_for(Signature $sig, &r?, :$with-typeobj) {
    my $params   := nqp::getattr($sig.params,List,'$!reified');
    my int $elems = nqp::elems($params);

    # not sending Method's default slurpy *%_ (which is always last)
    --$elems
      if nqp::istype(&r,Method)
      && nqp::iseq_s(nqp::atpos($params,$elems - 1).name,'%_');

    # build list
    my $result := nqp::setelems(nqp::list,$elems);
    my int $i   = -1;
    nqp::bindpos($result,$i,
      param_hash_for(nqp::atpos($params,$i),:$with-typeobj)
    ) while nqp::islt_i($i = nqp::add_i($i,1),$elems);

    $result
}

# Builds a hash of type information for the specified return type.
sub return_hash_for(Signature $s, &r?, :$with-typeobj, :$entry-point) {
    my Mu $result := nqp::hash();
    my $returns := $s.returns;
    nqp::bindkey($result, 'typeobj',     nqp::decont($returns))     if $with-typeobj;
    nqp::bindkey($result, 'entry_point', nqp::decont($entry-point)) if $entry-point;
    if $returns ~~ Str {
        my $enc := &r.?native_call_encoded // 'utf8';
        nqp::bindkey($result, 'type', nqp::unbox_s(string_encoding_to_nci_type($enc)));
        nqp::bindkey($result, 'free_str', nqp::unbox_i(0));
    }
    elsif $returns =:= Mu or $returns =:= void {
        nqp::bindkey($result, 'type', 'void');
    }
    # TODO: If we ever want to handle function pointers returned from C, this
    # bit of code needs to handle that.
    else {
        nqp::bindkey($result, 'type', nqp::unbox_s(type_code_for($returns)));
    }
    $result
}

my $signed_ints_by_size :=
  nqp::list_s( "", "char", "short", "", "int", "", "", "", "longlong" );

# Gets the NCI type code to use based on a given Perl 6 type.
my $type_map := nqp::hash(
  "Bool",       nqp::atpos_s($signed_ints_by_size,nativesizeof(bool)),
  "bool",       nqp::atpos_s($signed_ints_by_size,nativesizeof(bool)),
  "Callable",   "callback",
  "Int",        "longlong",
  "int",        "long",
  "int16",      "short",
  "int32",      "int",
  "int64",      "longlong",
  "int8",       "char",
  "long",       "long",
  "longdouble", "longdouble",
  "longlong",   "longlong",
  "Num",        "double",
  "num",        "double",
  "num32",      "float",
  "num64",      "double",
  "size_t",     nqp::atpos_s($signed_ints_by_size,nativesizeof(size_t)),
  "ssize_t",    nqp::atpos_s($signed_ints_by_size,nativesizeof(ssize_t)),
  "uint",       "ulong",
  "uint16",     "ushort",
  "uint32",     "uint",
  "uint64",     "ulonglong",
  "uint8",      "uchar",
  "ulong",      "ulong",
  "ulonglong",  "ulonglong",
);

my $repr_map := nqp::hash(
  "CArray",    "carray",
  "CPPStruct", "cppstruct",
  "CPointer",  "cpointer",
  "CStruct",   "cstruct",
  "CUnion",    "cunion",
  "VMArray",   "vmarray",
);


sub type_code_for(Mu ::T) {
    if T.?native_call_nci_type_code -> $type {
        $type;
    }
    elsif nqp::atkey($type_map,T.^shortname) -> $type {
        $type
    }
    elsif nqp::atkey($repr_map,T.REPR) -> $type {
        $type
    }
    # The REPR of any un-punned Role's type object is Uninstantiable,
    # so needs extra special cases here that aren't covered in the
    # hash lookups above.
    elsif nqp::istype(T,Blob) {
        "vmarray"
    }
    elsif nqp::istype(T,Pointer) {
        "cpointer"
    }
    else {
        die
"Unknown type {T.^name} used in native call.\n" ~
"If you want to pass a struct, be sure to use the CStruct or\n" ~
"CPPStruct representation.\n" ~
"If you want to pass an array, be sure to use the CArray type.";
    }
}

sub dynamic_prefix($name) {
    if $*nativecall_dynamic_prefix -> $prefix {
        $name ~ $prefix
    } else {
        $name;
    }
}

sub gen_native_symbol(Routine $r, :$cpp-name-mangler) {
    my $native_symbol = $r.?native_symbol;
    my $name = $native_symbol // dynamic_prefix($r.name);
    if ! $r.?native_call_mangled {
        # Native symbol or name is said to be already mangled
        $native_symbol // $name;
    } elsif $r.package.REPR eq 'CPPStruct' {
        # Mangle C++ classes
        $cpp-name-mangler($r, $native_symbol // ($r.package.^name ~ '::' ~ $name));
    } else {
        # Mangle C
        $cpp-name-mangler($r, $native_symbol // $name)
    }
}

multi sub map_return_type(Mu $type) { Mu }
multi sub map_return_type($type) {
    nqp::istype($type, Int) ?? Int
                            !! nqp::istype($type, Num) ?? Num !! $type;
}

sub guess_library_name($lib --> Str) is export(:TEST) {
    my $apiversion = '';
    my $libname = do given $lib {
        when IO::Path {
            $lib.absolute;
        }
        when $lib.?platform-library-name {
            return .Str;
        }
        when Callable {
           $lib();
        }
        when List {
           $apiversion = $lib[1];
           $lib[0];
        }
        when Str {
           $lib;
        }
        when Bool and .so {
            Str;
        }
		when Whatever {
			$*nativecall_library //
				die 'Dynamic variable $*nativecall_library is undefined';
		}
        default {
            die "A native library must be one of "~
                "IO::Path, Callable, List, Str, or Distribution::Resource";
        }
    };
    return '' unless $libname.DEFINITE;
    #Already a full name?
    return $libname if ($libname ~~ /\.<.alpha>+$/ or $libname ~~ /\.so(\.<.digit>+)+$/);
    return $*VM.platform-library-name($libname.IO, :version($apiversion || Version)).Str;
}

sub check_signature_sanity(Str $subname, Signature $sig, Bool $is_method?) is export(:TEST) {
    #Maybe this should use the hash already existing?
    sub validnctype (Mu ::T) {
      return True if nqp::existskey($repr_map,T.REPR) && T.REPR ne 'CArray' | 'CPointer';
      return True if T.^name eq 'Str' | 'str' | 'Bool';
      return False if T.REPR eq 'P6opaque';
      return False if T.HOW.^can("nativesize") && T.^nativesize == 0; #to disting int and int32 for example
      return validnctype(T.of) if T.REPR eq 'CArray' | 'CPointer' and T.^can('of');
      return True;
    }
    for @($sig.params).kv -> $i, $param {
        next if $is_method and ($i < 1 or $i == $sig.params.elems - 1); #Method have two extra parameters
        if $param.type ~~ Callable {
            check_signature_sanity( "$subname param $i Callable", $param.sub_signature );
            next;
        }
        if $param.type.?native_call_sub_signature -> $subsig {
            check_signature_sanity( "$subname param $i Callback", $subsig );
            next;
        }
        next unless $param.type ~~ Buf | Blob #Buf are Uninstantiable, make this buggy
        || $param.type.^can('gist'); #FIXME, it's to handle case of class A { sub foo(A) is native) }, the type is not complete
        if !validnctype($param.type) {
           warn "In '$subname' routine declaration - Not an accepted NativeCall type"
            ~ " for parameter [{$i + 1}] {$param.name ?? $param.name !! ''} : {$param.type.^name}\n"
            ~ " --> For Numerical type, use the appropriate int32/int64/num64...";
        }
    }
    return True if $sig.returns.REPR eq 'CPointer' | 'CStruct' | 'CPPStruct'; #Meh fix but 'imcomplete' type are a pain
    if $sig.returns.^name ne 'Mu' && !validnctype($sig.returns) {
        warn "The returning type of '$subname' --> {$sig.returns.^name} is erroneous."
            ~ " You should not return a non NativeCall supported type (like Int inplace of int32),"
            ~ " truncating errors can appear with different architectures";
    }
}

my %lib;
my @cpp-name-mangler =
    &NativeCall::Compiler::MSVC::mangle_cpp_symbol,
    &NativeCall::Compiler::GNU::mangle_cpp_symbol,
;

sub guess-name-mangler($routine, Str $libname) {
    my $sym = $routine.?native_symbol;
    unless $sym {
        my $name = dynamic_prefix($routine.name);
        $sym = do if $routine.package.REPR eq 'CPPStruct' {
            ($routine.package.^name ~ '::' ~ $name);
        } else {
            $name;
        };
    }
    for @cpp-name-mangler.kv -> $i, &mangler {
        next unless try cglobal($libname, mangler($routine, $sym), Pointer, :immediate);
        @cpp-name-mangler[ 0, $i ] .= reverse if $i; # Move to front on success.
        return &mangler;
    }
    die "Don't know how to mangle symbol '$sym' for library '$libname'"
}

my Lock $setup-lock .= new;

# This role is mixed in to any routine that is marked as being a
# native call.
my role Native {
    has int $!setup;
    has native_callsite $!call is box_target;
    has Str $!library_name;
    
    has Mu $!arg_info;
    has Mu $!return_hash;
    has Mu $!rettype;
    
    # Some of the setup can be done the instant we've got a signature
    # and either a library name or an entry point.
    method setup_nativecall(Pointer :$entry-point?, Str :$library_name?) {
        return if $!arg_info;
        $!library_name = guess_library_name( $library_name );
        $!arg_info := param_list_for(self.signature, self);
        $!return_hash := return_hash_for(self.signature, self, :$entry-point);
        $!rettype := nqp::decont(map_return_type(self.returns));
    }
    
    # Other parts cannot be done until later, because :native, :encoding, :symbol, etc.
    # can happen in any order.  Once the subroutine is called, though, the show must get
    # on the road.
    method CALL-ME(|args) {
        $setup-lock.protect: {
            return self.CALL-ME(args) if $!setup;
            # Make sure that C++ methods are treated as mangled (unless set otherwise)
            my $is_mangled = self.?native_call_mangled;
            if self.package.REPR eq 'CPPStruct' and !$is_mangled.DEFINITE {
                $is_mangled = True;
                self does role :: { method native_call_mangled { True } };
            }
            # if needed, try to guess mangler
            my $cpp-name-mangler = Any;
            $cpp-name-mangler = (%lib{$!library_name} //= guess-name-mangler(self, $!library_name)) if $is_mangled;
            
            my Mu $rettype = $!rettype;
			my Str $symbol_to_call := gen_native_symbol(self, :$cpp-name-mangler);
            my Str $calling_convention = self.?native_call_convention // '';
            nqp::buildnativecall(self,
                nqp::unbox_s($!library_name),
                nqp::unbox_s($symbol_to_call),
                nqp::unbox_s($calling_convention),
                $!arg_info,
                $!return_hash);
            self does my role NativeRoutineFullyBuilt {
				method setup_nativecall {}
                method CALL-ME(|args) {
                    my Mu $args := nqp::getattr(nqp::decont(args), Capture, '@!list');
                    if nqp::elems($args) != self.signature.arity {
                        X::TypeCheck::Argument.new(
                            :objname(:name(self.name)),
                            :arguments(args.list.map(*.^name))
                            :signature(try self.signature.gist),
                        ).throw
                    }
                    nqp::nativecall($rettype, self, $args)
                }
            }
            $!setup = 1;
        }
        self.CALL-ME: |args;
    }
}

multi trait_mod:<is>(Routine $r, :$symbol!) is export(:DEFAULT, :traits) {
    $r does my role NativeCallSymbol { method native_symbol { $symbol } };
}

# Specifies that the routine is actually a native call, into the
# current executable (platform specific) or into a named library
multi trait_mod:<is>(Routine $r, :$native!) is export(:DEFAULT, :traits) {
    check_signature_sanity($r.name, $r.signature, $r ~~ Method);
    $r does Native;
    $r.setup_nativecall( :library_name($native) );
}

# Specifies the calling convention to use for a native call.
multi trait_mod:<is>(Routine $r, :$nativeconv!) is export(:DEFAULT, :traits) {
    $r does my role NativeCallingConvention { method native_call_convention { $nativeconv } };
}

# Ways to specify how to marshall strings.
multi trait_mod:<is>(Parameter $p, :$encoded!) is export(:DEFAULT, :traits) {
    $p does my role NativeCallEncoded { method native_call_encoded { $encoded } };
}
multi trait_mod:<is>(Routine $p, :$encoded!) is export(:DEFAULT, :traits) {
    $p does my role NativeCallEncoded { method native_call_encoded { $encoded } };
}

multi trait_mod:<is>(Routine $p, :$mangled!) is export(:DEFAULT, :traits) {
    $p does my role NativeCallMangled { method native_call_mangled { $mangled } };
}

multi explicitly-manage(Str $x, :$encoding = 'utf8') is export(:DEFAULT, :utils) {
    my class CStr is repr('CStr') { method encoding() { $encoding; } };
    $x does my role ExplicitlyManagedString { has $.cstr is rw };
    # Fields of repr CStr (MVM_REPR_ID_MVMCStr) are specially treated.
    $x.cstr = nqp::box_s(nqp::unbox_s($x), CStr);
}

multi trait_mod:<is>(Parameter $p, :$cpp-const!) is export(:DEFAULT, :traits) {
    $p does role CPPConst { method cpp-const() { 1 } };
}

multi trait_mod:<is>(Parameter $p, :$cpp-ref!) is export(:DEFAULT, :traits) {
    $p does role CPPRef { method cpp-ref() { 1 } };
}

multi refresh($obj) is export(:DEFAULT, :utils) {
    nqp::nativecallrefresh($obj);
    1;
}

multi sub nativecast(Signature $target-type, $entry-point) is export(:DEFAULT, :traits) {
    check_signature_sanity( $entry-point.gist, $target-type );
    my $r := sub { };
    nqp::bindattr($r, Code, '$!signature', nqp::decont($target-type));
    $r does Native;
    $r.setup_nativecall( :$entry-point );
    $r
}

multi sub nativecast($target-type, $pointer) is export {
    nqp::nativecallcast(nqp::decont($target-type),
        nqp::decont(map_return_type($target-type)), nqp::decont($pointer));
}

multi sub nativecast(Pointer:U ::ptr_t, Signature $how, Callable $source) is export {
    my &deep_magic := %{$how.perl} //= do {
        my $sig = :(&, Str, int32 --> Pointer);
        my Mu \param := nqp::decont($sig.params[0]);
        nqp::bindattr( param, Parameter, '$!sub_signature', nqp::decont($how));
        my sub memcpy { };
        nqp::bindattr(&memcpy, Code, '$!signature', nqp::decont($sig));
        &memcpy does Native;
        &memcpy.setup_nativecall;
        &memcpy;
    };
    my $pointer = deep_magic( $source, '', 0 );
    nqp::rebless( $pointer, ptr_t );
    $pointer;
}

sub nativesizeof($obj) is export {
    nqp::nativecallsizeof($obj)
}

proto cglobal($libname, $symbol, $target-type, |) is export { * };

multi cglobal($libname, $symbol, $target-type, :$immediate!) is export {
    # This variant fetches the global variable as soon as it is called, 
    # and does not produce a Proxy.
    nqp::nativecallglobal(
        nqp::unbox_s(guess_library_name($libname)),
        nqp::unbox_s($symbol),
        nqp::decont($target-type),
        nqp::decont(map_return_type($target-type)))
}

multi cglobal($libname, $symbol, $target-type) is rw is export {
    # This variant produces a read-only Proxy.  If you bind it to a
    # variable, then every time you read from that variable, the C
    # variable is fetched.  Speed?  Who needs Speed?
    Proxy.new:
        FETCH => -> $ { cglobal($libname, $symbol, $target-type, :immediate) },
        STORE => -> $, $ { die "Use the :rw option if you need writable C globals" };
}

multi cglobal($libname, $symbol, $target_type, :$rw!) is rw is export {
    # From the outside, there's not much difference between a C global
    # variable which is an int, and a C global variable which is an
    # array containing a single int...
    
    # We create a CArray of $target-type, as soon as either of
    # our Proxy's FETCH or STORE are used.
    my sub as_array {
        state Mu $ = nqp::decont(cglobal($libname, $symbol, CArray[$target_type], :immediate));
    };
    if $target_type ~~ Int  {
        Proxy.new:
            FETCH => -> $ { nqp::atpos_i(as_array, 0) },
            STORE => -> $, $arg { nqp::bindpos_i(as_array, 0, nqp::decont($arg)) };
    } elsif $target_type ~~ Num {
        Proxy.new:
            FETCH => -> $ { nqp::atpos_n(as_array, 0) },
            STORE => -> $, $arg { nqp::bindpos_n(as_array, 0, nqp::decont($arg)) };
    } else {
        Proxy.new:
            FETCH => -> $ { nqp::atpos(as_array, 0) },
            STORE => -> $, $arg { nqp::bindpos(as_array, 0, nqp::decont($arg)) };
    }
}

multi cglobal($libname, $symbol, $target-type, :$rw!, :$immediate!) is rw is export {
    # This variant produces the fastest Proxy objects for C global variables.
    # If you need to access such variables in a tight loop, consider this function.
    
    # This variant of cglobal will fail *immediately* if the specified
    # library does not have a variable of that name.
    
    my Mu \as_array := nqp::decont(cglobal($libname, $symbol, CArray[$target-type], :immediate));
    if $target-type ~~ Int  {
        nqp::atposref_i( as_array, 0 );
    } elsif $target-type ~~ Num {
        nqp::atposref_n( as_array, 0 );
    } else {
        Proxy.new:
            FETCH => -> $ { nqp::atpos(as_array, 0) },
            STORE => -> $, $arg { nqp::bindpos(as_array, 0, nqp::decont($arg)) };
    }
}

multi sub FUNCTION_POINTER (Signature:D $signature) is export {
    class FunctionPointer is Pointer is Callable {
        method new($r) { nativecast( self, $signature, $r ) }
        method signature { $signature }
        method returns { $signature.returns }
        method Callable { $ = nativecast( $signature, self ) }
        method FALLBACK( $name, |args ) { self.Callable."$name"(|args) }
    };
};

my sub attribute_mixin(Mu ::fptr_t) {
    role FunctionPointerAttribute {
        multi method set_value(Mu \instance, fptr_t \p ) {
            self.Attribute::set_value( instance, p );
        }
        multi method set_value(Mu \instance, Pointer:D \p ) {
            self.Attribute::set_value( instance, nativecast( fptr_t, p ) );
        }
        multi method set_value(Mu \instance, Callable:D \c ) {
            self.Attribute::set_value( instance, fptr_t.new(c) );
        }
    }
}


multi trait_mod:<is> (Attribute \a, Signature:D $callable!) {
    my $f = FUNCTION_POINTER $callable;
    nqp::bindattr( a, Attribute, '$!type', nqp::decont($f) );
    a does attribute_mixin( $f );
}

}

=finish
# vim:ft=perl6

output

C:\Users\Ben (user)\code\Perl6Misc>perl6 -I. -e "use NativeCall; my sub puts(Str) is native {...};"
===SORRY!=== Error while compiling -e
Can't use unknown trait 'is native' in a sub declaration.
at -e:1
    expecting any of:
        rw raw hidden-from-backtrace hidden-from-USAGE
        pure default DEPRECATED inlinable nodal
        prec equiv tighter looser assoc leading_docs trailing_docs