Skip Menu |
Report information
Id: 127460
Status: open
Priority: 0/
Queue: perl6

Owner: Nobody
Requestors: drforr [at] pobox.com
Cc:
AdminCc:

Severity: (no value)
Tag: (no value)
Platform: (no value)
Patch Status: (no value)
VM: (no value)



Date: Thu, 04 Feb 2016 21:46:32 +0100
From: drforr [...] pobox.com
To: Rakudobug <rakudobug [...] perl.org>
Subject: NativeCall CUnion bug
Download (untitled) / with headers
text/plain 4.9k
Setting an int32 member of a CUnion (nested in a CStruct) to 0 from C causes the NativeCall layer to return a type object to the user. This is a bit bizarre, but the files are below. I'm nesting a CUnion within a CStruct in order to match the layout of the C struct. -- bug.pm6 -- use NativeCall; constant ZERO = 0; constant TYPE_BOOL = 2; class Inline::Scheme::Guile::AltType is repr('CUnion') { has int32 $.int_content; # When this is populated with 0, NativeCall returns the I::S::G::AltType type rather than an instance of the object. has Str $.string_content; } class Inline::Scheme::Guile::ConsCell is repr('CStruct') { has int32 $.type; HAS Inline::Scheme::Guile::AltType $.content; # The nested CUnion is here. } class Inline::Scheme::Guile { sub native(Sub $sub) { my Str $path = %?RESOURCES<libraries/guile-helper>.Str; die "unable to find libguile-helper library" unless $path; trait_mod:<is>($sub, :native($path)); } sub run( Str $expression, &marshal_guile (Pointer[Inline::Scheme::Guile::ConsCell]) ) { ... } native(&run); method run( Str $expression ) { my @stuff; my $ref = sub ( Pointer[Inline::Scheme::Guile::ConsCell] $cell ) { CATCH { warn "Don't die in callback, warn instead.\n"; warn $_; } my $type = $cell.deref.type; given $type { when TYPE_BOOL { my $content = $cell.deref.content; # Content comes back as the AltType type object rather than an instance. if $content.int_content == 1 { @stuff.push( True ); } else { @stuff.push( False ); } } } } run( $expression, $ref ); return @stuff; } } --cut here-- -- bug.c -- #include <libguile.h> #include <stdio.h> typedef enum { VOID = -1, ZERO = 0, TYPE_BOOL = 2, } cons_cell_type; typedef struct { cons_cell_type type; union { long int_content; // This is the problem. char* string_content; }; } cons_cell; static void _walk_scm( SCM scm, cons_cell* result ) { int num_values = scm_c_nvalues( scm ); // '#f' is not null, bool, false and only 1 value. // if ( num_values == 1 && //scm_is_null( scm ) && scm_is_bool( scm ) && scm_is_false( scm ) ) { result[0].type = TYPE_BOOL; // result[0].int_content = -1; // Assigning -1 to int_content returns an instance result[0].int_content = 0; // Assigning 0 to int_content returns the type object. result[1].type = ZERO; return; } // '#t' is not null, bool, not false, true and only 1 value. // if ( num_values == 1 && //scm_is_null( scm ) && scm_is_bool( scm ) && !scm_is_false( scm ) && scm_is_true( scm ) ) { result[0].type = TYPE_BOOL; result[0].int_content = 1; result[1].type = ZERO; return; } } void* _run( void* expression ) { SCM str = scm_from_latin1_string( (char*) expression ); SCM scm = scm_eval_string( str ); // Sigh, special-case void lists. if ( scm_c_nvalues( scm ) == 0 ) { cons_cell* result = malloc( sizeof( cons_cell ) * 2 ); result[0].type = VOID; result[1].type = ZERO; return result; } cons_cell* result = malloc( sizeof( cons_cell ) * 2 ); _walk_scm( scm, result ); return result; } void run( const char* expression, void (*unmarshal(void*)) ) { cons_cell* cells = scm_with_guile( _run, (void*)expression ); cons_cell* head = cells; while( head->type != ZERO ) { unmarshal(head++); } free(cells); } --cut here-- -- t/00-core.t -- #!/usr/bin/env perl6 use v6; use Test; use NativeCall; plan 3; use Inline::Scheme::Guile; my $g = Inline::Scheme::Guile.new; is-deeply [ $g.run( q{#f} ) ], [ False ], q{value (#f)}; # This should segfault when 0 is used as False rather than -1. is-deeply [ $g.run( q{#t} ) ], [ True ], q{value (#t)}; # This should work regardless. --cut here--
Download (untitled) / with headers
text/plain 151b
This is probably fixed by https://github.com/MoarVM/MoarVM/commit/d9123780114274883114290e12e689c81391fd8b Can you please re-test with current rakudo?


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

For issues related to this RT instance (aka "perlbug"), please contact perlbug-admin at perl.org